/* Subroutine */ int zsyt03_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *ainv, integer *ldainv, doublecomplex *
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, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublereal eps;
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
doublereal ainvnm;
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
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 */
/* ======= */
/* ZSYT03 computes the residual for a complex symmetric matrix times */
/* its inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AINV (input/output) COMPLEX*16 array, dimension (LDAINV,N) */
/* On entry, the inverse of the matrix A, stored as a symmetric */
/* matrix in the same format as A. */
/* In this version, AINV is expanded into a full matrix and */
/* multiplied by A, so the opposing triangle of AINV will be */
/* changed; i.e., if the upper triangular part of AINV is */
/* stored, the lower triangular part will be used as work space. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* WORK (workspace) COMPLEX*16 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 */
/* RCOND = 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 = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
ainvnm = zlansy_("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 ZSYMM to multiply */
/* AINV on the left by A (store the result in WORK). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L30: */
}
/* L40: */
}
}
z__1.r = -1., z__1.i = -0.;
zsymm_("Left", uplo, n, n, &z__1, &a[a_offset], lda, &ainv[ainv_offset],
ldainv, &c_b1, &work[work_offset], ldwork);
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (doublereal) (*n);
return 0;
/* End of ZSYT03 */
} /* zsyt03_ */
/* Subroutine */ int zchksy_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
doublecomplex *x, doublecomplex *xact, doublecomplex *work,
doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
integer iuplo, izero, nerrs, lwork;
extern /* Subroutine */ int zpot05_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int zsyt01_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zsyt02_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zsyt03_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *), zlatb4_(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 alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
logical trfcon;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal result[8];
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zlatsy_(char *, integer *, doublecomplex *,
integer *, integer *), zerrsy_(char *, integer *),
zsyrfs_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *), zsytrf_(char *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *
, integer *, integer *), zsytri_(char *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKSY tests ZSYTRF, -TRI, -TRS, -RFS, and -CON. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(2,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, */
/* dimension (NMAX+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrsy_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (imat != 11) {
/* Set up parameters with ZLATB4 and generate a test */
/* matrix with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "N", &a[1], &lda, &work[
1], &info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of */
/* the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
if (iuplo == 1) {
/* Set the first IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* Use a special block diagonal matrix to test alternate */
/* code for the 2 x 2 blocks. */
zlatsy_(uplo, &n, &a[1], &lda, iseed);
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*D*L' or U*D*U' factorization of the */
/* matrix. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
lwork = max(2,nb) * lda;
s_copy(srnamc_1.srnamt, "ZSYTRF", (ftnlen)6, (ftnlen)6);
zsytrf_(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 ZSYTRF. */
if (info != k) {
alaerh_(path, "ZSYTRF", &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. */
zsyt01_(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) {
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "ZSYTRI", (ftnlen)6, (ftnlen)
6);
zsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
/* Check error code from ZSYTRI. */
if (info != 0) {
alaerh_(path, "ZSYTRI", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
zsyt03_(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, "ZLARHS", (ftnlen)6, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZSYTRS", (ftnlen)6, (ftnlen)
6);
zsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
x[1], &lda, &info);
/* Check error code from ZSYTRS. */
if (info != 0) {
alaerh_(path, "ZSYTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
zsyt02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZSYRFS", (ftnlen)6, (ftnlen)
6);
zsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
1) + 1], &info);
/* Check error code from ZSYRFS. */
if (info != 0) {
alaerh_(path, "ZSYRFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___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 = zlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "ZSYCON", (ftnlen)6, (ftnlen)6);
zsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
rcond, &work[1], &info);
/* Check error code from ZSYCON. */
if (info != 0) {
alaerh_(path, "ZSYCON", &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 ZCHKSY */
} /* zchksy_ */
/* Subroutine */ int zlqt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *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 */
doublereal eps;
integer info;
doublereal resid, anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT02 tests ZUNGLQ, 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, ZLQT02 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) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZLQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* L (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 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 ) */
/* ===================================================================== */
/* .. 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 */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
zlacpy_("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)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("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' */
zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT02 */
} /* zlqt02_ */
/* Subroutine */ int zunt01_(char *rowcol, integer *m, integer *n,
doublecomplex *u, integer *ldu, doublecomplex *work, integer *lwork,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal eps;
doublecomplex tmp;
extern logical lsame_(char *, char *);
integer mnmin;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
integer ldwork;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
char transu[1];
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
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 */
/* ======= */
/* ZUNT01 checks that the matrix U is unitary by computing the ratio */
/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* Alternatively, if there isn't sufficient workspace to form */
/* I - U*U' or I - U'*U, the ratio is computed as */
/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* where EPS is the machine precision. ROWCOL is used only if m = n; */
/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
/* assumed to be 'R'. */
/* Arguments */
/* ========= */
/* ROWCOL (input) CHARACTER */
/* Specifies whether the rows or columns of U should be checked */
/* for orthogonality. Used only if M = N. */
/* = 'R': Check for orthogonal rows of U */
/* = 'C': Check for orthogonal columns of U */
/* M (input) INTEGER */
/* The number of rows of the matrix U. */
/* N (input) INTEGER */
/* The number of columns of the matrix U. */
/* U (input) COMPLEX*16 array, dimension (LDU,N) */
/* The unitary matrix U. U is checked for orthogonal columns */
/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. For best performance, LWORK */
/* should be at least N*N if ROWCOL = 'C' or M*M if */
/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (min(M,N)) */
/* Used only if LWORK is large enough to use the Level 3 BLAS */
/* code. */
/* RESID (output) DOUBLE PRECISION */
/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
/* Function Body */
*resid = 0.;
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return 0;
}
eps = dlamch_("Precision");
if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
*(unsigned char *)transu = 'N';
k = *n;
} else {
*(unsigned char *)transu = 'C';
k = *m;
}
mnmin = min(*m,*n);
if ((mnmin + 1) * mnmin <= *lwork) {
ldwork = mnmin;
} else {
ldwork = 0;
}
if (ldwork > 0) {
/* Compute I - U*U' or I - U'*U. */
zlaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
zherk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b11,
&work[1], &ldwork);
/* Compute norm( I - U*U' ) / ( K * EPS ) . */
*resid = zlansy_("1", "Upper", &mnmin, &work[1], &ldwork, &rwork[1]);
*resid = *resid / (doublereal) k / eps;
} else if (*(unsigned char *)transu == 'C') {
/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
1], &c__1);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L10: */
}
/* L20: */
}
*resid = *resid / (doublereal) (*m) / eps;
} else {
/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp.r = 0., tmp.i = 0.;
} else {
tmp.r = 1., tmp.i = 0.;
}
zdotc_(&z__2, n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
tmp.r = z__1.r, tmp.i = z__1.i;
/* Computing MAX */
d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
d_imag(&tmp), abs(d__2));
*resid = max(d__3,d__4);
/* L30: */
}
/* L40: */
}
*resid = *resid / (doublereal) (*n) / eps;
}
return 0;
/* End of ZUNT01 */
} /* zunt01_ */
/* Subroutine */ int zspt01_(char *uplo, integer *n, doublecomplex *a,
doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
static integer info, i__, j;
extern logical lsame_(char *, char *);
static doublereal anorm;
static integer jc;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlavsp_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal eps;
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZSPT01 reconstructs a symmetric indefinite packed matrix A from its
diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes
the residual
norm( C - A ) / ( N * norm(A) * EPS ),
where C is the reconstructed matrix and EPS is the machine epsilon.
Arguments
==========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The original symmetric matrix A, stored as a packed
triangular matrix.
AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The factored form of the matrix A, stored as a packed
triangular matrix. AFAC contains the block diagonal matrix D
and the multipliers used to obtain the factor L or U from the
L*D*L' or U*D*U' factorization as computed by ZSPTRF.
IPIV (input) INTEGER array, dimension (N)
The pivot indices from ZSPTRF.
C (workspace) COMPLEX*16 array, dimension (LDC,N)
LDC (integer) INTEGER
The leading dimension of the array C. LDC >= max(1,N).
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if N = 0.
Parameter adjustments */
--a;
--afac;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]);
/* Initialize C to the identity matrix. */
zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call ZLAVSP to form the product D * U' (or D * L' ). */
zlavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Call ZLAVSP again to multiply by U ( or L ). */
zlavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = jc + i__;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L10: */
}
jc += j;
/* L20: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = jc + i__ - j;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
jc = jc + *n - j + 1;
/* L40: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of ZSPT01 */
} /* zspt01_ */
/* Subroutine */ int zrqt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *tau, doublecomplex *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;
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZRQT02 tests ZUNGRQ, 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, ZRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZRQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by ZGERQF. */
/* See ZGERQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* R (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 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 */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
zlacpy_("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;
zlacpy_("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, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
zungrq_(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) */
zlaset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
zlacpy_("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)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
(*n - *m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = zlange_("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' */
zlaset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZRQT02 */
} /* zrqt02_ */
/* Subroutine */
int zsyrfsx_(char *uplo, char *equed, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer * ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal * err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex * work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
integer ref_type__, j;
doublereal rcond_tmp__;
integer prec_type__;
doublereal cwise_wrong__;
char norm[1];
extern /* Subroutine */
int zla_syrfsx_extended_(integer *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, logical *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, doublecomplex *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, logical *, integer *);
logical ignore_cwise__;
extern logical lsame_(char *, char *);
doublereal anorm;
logical rcequ;
extern doublereal zla_syrcond_c_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublereal *, logical *, integer *, doublecomplex *, doublereal *), zla_syrcond_x_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *), dlamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */
int zsycon_(char *, integer *, doublecomplex *, integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *);
extern integer ilaprec_(char *);
integer ithresh, n_norms__;
doublereal rthresh;
/* -- LAPACK computational routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check the input parameters. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
ref_type__ = 1;
if (*nparams >= 1)
{
if (params[1] < 0.)
{
params[1] = 1.;
}
else
{
ref_type__ = (integer) params[1];
}
}
/* Set default parameters. */
illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
ithresh = 10;
rthresh = .5;
unstable_thresh__ = .25;
ignore_cwise__ = FALSE_;
if (*nparams >= 2)
{
if (params[2] < 0.)
{
params[2] = (doublereal) ithresh;
}
else
{
ithresh = (integer) params[2];
}
}
if (*nparams >= 3)
{
if (params[3] < 0.)
{
if (ignore_cwise__)
{
params[3] = 0.;
}
else
{
params[3] = 1.;
}
}
else
{
ignore_cwise__ = params[3] == 0.;
}
}
if (ref_type__ == 0 || *n_err_bnds__ == 0)
{
n_norms__ = 0;
}
else if (ignore_cwise__)
{
n_norms__ = 1;
}
else
{
n_norms__ = 2;
}
rcequ = lsame_(equed, "Y");
/* Test input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! rcequ && ! lsame_(equed, "N"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -12;
}
else if (*ldx < max(1,*n))
{
*info = -14;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSYRFSX", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *nrhs == 0)
{
*rcond = 1.;
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
berr[j] = 0.;
if (*n_err_bnds__ >= 1)
{
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
if (*n_err_bnds__ >= 2)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
}
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
}
}
return 0;
}
/* Default to failure. */
*rcond = 0.;
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
berr[j] = 1.;
if (*n_err_bnds__ >= 1)
{
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
if (*n_err_bnds__ >= 2)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
}
}
/* Compute the norm of A and the reciprocal of the condition */
/* number of A. */
*(unsigned char *)norm = 'I';
anorm = zlansy_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
zsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], info);
/* Perform refinement on each right-hand side */
if (ref_type__ != 0)
{
prec_type__ = ilaprec_("E");
zla_syrfsx_extended_(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &n_norms__, & err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1], & rwork[1], rcond, &ithresh, &rthresh, &unstable_thresh__, & ignore_cwise__, info);
}
/* Computing MAX */
d__1 = 10.;
d__2 = sqrt((doublereal) (*n)); // , expr subst
err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
if (*n_err_bnds__ >= 1 && n_norms__ >= 1)
{
/* Compute scaled normwise condition number cond(A*C). */
if (rcequ)
{
rcond_tmp__ = zla_syrcond_c_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1] , &rwork[1]);
}
else
{
rcond_tmp__ = zla_syrcond_c_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[ 1], &rwork[1]);
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] > 1.)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
if (*info <= *n)
{
*info = *n + j;
}
}
else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < err_lbnd__)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
}
}
}
if (*n_err_bnds__ >= 1 && n_norms__ >= 2)
{
/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/* each right-hand side using the current solution as an estimate of */
/* the true solution. If the componentwise error estimate is too */
/* large, then the solution is a lousy estimate of truth and the */
/* estimated RCOND may be too optimistic. To avoid misleading users, */
/* the inverse condition number is set to 0.0 when the estimated */
/* cwise error is at least CWISE_WRONG. */
cwise_wrong__ = sqrt(dlamch_("Epsilon"));
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < cwise_wrong__)
{
rcond_tmp__ = zla_syrcond_x_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info, &work[1], &rwork[1]);
}
else
{
rcond_tmp__ = 0.;
}
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] > 1.)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
if (! ignore_cwise__ && *info < *n + j)
{
*info = *n + j;
}
}
else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < err_lbnd__)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3)
{
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
}
}
}
return 0;
/* End of ZSYRFSX */
}
/* Subroutine */ int zsyt01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, integer *ipiv,
doublecomplex *c__, integer *ldc, doublereal *rwork, doublereal *
resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublereal eps;
integer info;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSYT01 reconstructs a complex symmetric indefinite matrix A from its */
/* block L*D*L' or U*D*U' factorization and computes the residual */
/* norm( C - A ) / ( N * norm(A) * EPS ), */
/* where C is the reconstructed matrix, EPS is the machine epsilon, */
/* L' is the transpose of L, and U' is the transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor L or U from the block L*D*L' or U*D*U' factorization */
/* as computed by ZSYTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZSYTRF. */
/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
/* LDC (integer) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Initialize C to the identity matrix. */
zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call ZLAVSY to form the product D * U' (or D * L' ). */
zlavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
ipiv[1], &c__[c_offset], ldc, &info);
/* Call ZLAVSY again to multiply by U (or L ). */
zlavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
ipiv[1], &c__[c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of ZSYT01 */
} /* zsyt01_ */
/* Subroutine */ int zrqt01_(integer *m, integer *n, doublecomplex *a,
doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda,
doublecomplex *tau, doublecomplex *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;
doublereal resid, anorm;
integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zgerqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n */
/* matrix A, and partially tests ZUNGRQ which forms the n-by-n */
/* orthogonal matrix Q. */
/* ZRQT01 compares R with A*Q', and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by ZGERQF. */
/* See ZGERQF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The n-by-n orthogonal matrix Q. */
/* R (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGERQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
/* 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 .. */
/* 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 */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)6, (ftnlen)6);
zgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
q_dim1], lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
q[q_dim1 + 2], lda);
}
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6);
zungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy R */
zlaset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda);
if (*m <= *n) {
if (*m > 0) {
zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
r__[(*n - *m + 1) * r_dim1 + 1], lda);
}
} else {
if (*m > *n && *n > 0) {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
lda);
}
if (*n > 0) {
zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
*n + 1 + r_dim1], lda);
}
}
/* Compute R - A*Q' */
zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[
a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda);
zherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZRQT01 */
} /* zrqt01_ */
/* Subroutine */
int zsysvx_(char *fact, char *uplo, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer * ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
doublereal anorm;
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer lwkopt;
logical lquery;
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */
int zsycon_(char *, integer *, doublecomplex *, integer *, integer *, doublereal *, doublereal *, doublecomplex *, integer *), zsyrfs_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *), zsytrf_(char *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
lquery = *lwork == -1;
if (! nofact && ! lsame_(fact, "F"))
{
*info = -1;
}
else if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -11;
}
else if (*ldx < max(1,*n))
{
*info = -13;
}
else /* if(complicated condition) */
{
/* Computing MAX */
i__1 = 1;
i__2 = *n << 1; // , expr subst
if (*lwork < max(i__1,i__2) && ! lquery)
{
*info = -18;
}
}
if (*info == 0)
{
/* Computing MAX */
i__1 = 1;
i__2 = *n << 1; // , expr subst
lwkopt = max(i__1,i__2);
if (nofact)
{
nb = ilaenv_(&c__1, "ZSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkopt;
i__2 = *n * nb; // , expr subst
lwkopt = max(i__1,i__2);
}
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSYSVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
if (nofact)
{
/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */
zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
zsytrf_(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 = zlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
zsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
zsytrs_(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. */
zsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] , &rwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon"))
{
*info = *n + 1;
}
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZSYSVX */
}
/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
doublereal anorm;
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer lwkopt;
logical lquery;
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zsyrfs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zsytrf_(char *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, 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 */
/* ======= */
/* ZSYSVX uses the diagonal pivoting factorization to compute the */
/* solution to a complex system of linear equations A * X = B, */
/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
/* matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
/* The form of the factorization is */
/* A = U * D * U**T, if UPLO = 'U', or */
/* A = L * D * L**T, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, AF and IPIV contain the factored form */
/* of A. A, AF and IPIV will not be modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF. */
/* 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 ZSYTRF. */
/* 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 ZSYTRF. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The estimate of the reciprocal condition number of the matrix */
/* A. If RCOND is less than the machine precision (in */
/* particular, if RCOND = 0), the matrix is singular to working */
/* precision. This condition is indicated by a return code of */
/* INFO > 0. */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK >= max(1,2*N), and for best */
/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
/* NB is the optimal blocksize for ZSYTRF. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: D(i,i) is exactly zero. The factorization */
/* has been completed but the factor D is exactly */
/* singular, so the solution and error bounds could */
/* not be computed. RCOND = 0 is returned. */
/* = N+1: D is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
lquery = *lwork == -1;
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwkopt = max(i__1,i__2);
if (nofact) {
nb = ilaenv_(&c__1, "ZSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkopt, i__2 = *n * nb;
lwkopt = max(i__1,i__2);
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYSVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
zsytrf_(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 = zlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
zsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
info);
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
zsytrs_(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. */
zsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
, &rwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZSYSVX */
} /* zsysvx_ */
/* Subroutine */ int zqlt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *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;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal resid, anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with
orthonornmal columns that is defined as the product of k elementary
reflectors.
Given the QL factorization of an m-by-n matrix A, ZQLT02 generates
the orthogonal matrix Q defined by the factorization of the last k
columns of A; it compares L(m-n+1:m,n-k+1:n) with
Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A which was factorized by ZQLT01.
AF (input) COMPLEX*16 array, dimension (LDA,N)
Details of the QL factorization of A, as returned by ZGEQLF.
See ZGEQLF for further details.
Q (workspace) COMPLEX*16 array, dimension (LDA,N)
L (workspace) COMPLEX*16 array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= M.
TAU (input) COMPLEX*16 array, dimension (N)
The scalar factors of the elementary reflectors corresponding
to the QL factorization in AF.
WORK (workspace) COMPLEX*16 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 )
=====================================================================
Quick return if possible
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 */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the last k columns of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *m) {
i__1 = *m - *k;
zlacpy_("Full", &i__1, k, &af_ref(1, *n - *k + 1), lda, &q_ref(1, *n
- *k + 1), lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *k + 1, *n - *k + 2), lda,
&q_ref(*m - *k + 1, *n - *k + 2), lda);
}
/* Generate the last n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6);
zungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
info);
/* Copy L(m-n+1:m,n-k+1:n) */
zlaset_("Full", n, k, &c_b9, &c_b9, &l_ref(*m - *n + 1, *n - *k + 1), lda);
zlacpy_("Lower", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &l_ref(*m
- *k + 1, *n - *k + 1), lda);
/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
q_offset], lda, &a_ref(1, *n - *k + 1), lda, &c_b15, &l_ref(*m - *
n + 1, *n - *k + 1), lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = zlange_("1", m, k, &a_ref(1, *n - *k + 1), lda, &rwork[1]);
resid = zlange_("1", n, k, &l_ref(*m - *n + 1, *n - *k + 1), lda, &rwork[
1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
zherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
c_b24, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of ZQLT02 */
} /* zqlt02_ */
/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZSYSVX uses the diagonal pivoting factorization to compute the
solution to a complex system of linear equations A * X = B,
where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the diagonal pivoting method is used to factor A.
The form of the factorization is
A = U * D * U**T, if UPLO = 'U', or
A = L * D * L**T, if UPLO = 'L',
where U (or L) is a product of permutation and unit upper (lower)
triangular matrices, and D is symmetric and block diagonal with
1-by-1 and 2-by-2 diagonal blocks.
2. 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, steps 3 and 4 are skipped.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': On entry, AF and IPIV contain the factored form
of A. A, AF and IPIV will not be modified.
= 'N': The matrix A will be copied to AF and factored.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The symmetric matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
If FACT = 'F', then AF is an input argument and on entry
contains the block diagonal matrix D and the multipliers used
to obtain the factor U or L from the factorization
A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.
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 ZSYTRF.
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 ZSYTRF.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) COMPLEX*16 array, dimension (LDX,NRHS)
If INFO = 0, 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, and the solution and error bounds are not computed.
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of WORK. LWORK >= 2*N, and for best performance
LWORK >= N*NB, where NB is the optimal blocksize for
ZSYTRF.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: D(i,i) is exactly zero. The factorization
has been completed, but the block diagonal
matrix D is exactly singular, so the solution and
error bounds could not be computed.
= N+1: the block diagonal matrix D is nonsingular, but
RCOND is less than machine precision. The
factorization has been completed, but the matrix
is singular to working precision, so the solution
and error bounds have not been computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
static doublereal anorm;
extern doublereal dlamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacpy_(
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zsyrfs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zsytrf_(char *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *);
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*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 (*lwork < *n << 1) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
zlacpy_(uplo, n, n, &A(1,1), lda, &AF(1,1), ldaf);
zsytrf_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &WORK(1), lwork,
info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = zlansy_("I", uplo, n, &A(1,1), lda, &RWORK(1));
/* Compute the reciprocal of the condition number of A. */
zsycon_(uplo, n, &AF(1,1), ldaf, &IPIV(1), &anorm, rcond, &WORK(1),
info);
/* Return if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
return 0;
}
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
zsytrs_(uplo, n, nrhs, &AF(1,1), ldaf, &IPIV(1), &X(1,1), ldx,
info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
zsyrfs_(uplo, n, nrhs, &A(1,1), lda, &AF(1,1), ldaf, &IPIV(1),
&B(1,1), ldb, &X(1,1), ldx, &FERR(1), &BERR(1), &WORK(1)
, &RWORK(1), info);
return 0;
/* End of ZSYSVX */
} /* zsysvx_ */
/* Subroutine */ int zqlt01_(integer *m, integer *n, doublecomplex *a,
doublecomplex *af, doublecomplex *q, doublecomplex *l, integer *lda,
doublecomplex *tau, doublecomplex *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;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal resid, anorm;
static integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zgeqlf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZQLT01 tests ZGEQLF, which computes the QL factorization of an m-by-n
matrix A, and partially tests ZUNGQL which forms the m-by-m
orthogonal matrix Q.
ZQLT01 compares L with Q'*A, and checks that Q is orthogonal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX*16 array, dimension (LDA,N)
Details of the QL factorization of A, as returned by ZGEQLF.
See ZGEQLF for further details.
Q (output) COMPLEX*16 array, dimension (LDA,M)
The m-by-m orthogonal matrix Q.
L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R.
LDA >= max(M,N).
TAU (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by ZGEQLF.
WORK (workspace) COMPLEX*16 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 )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGEQLF", (ftnlen)6, (ftnlen)6);
zgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n
+ 1), lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, &
q_ref(*m - *n + 1, *m - *n + 2), lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, &
q_ref(1, 2), lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6);
zungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
zlaset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
zlacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - *
n + 1, 1), lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
zlacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n
- *m + 1), lda);
}
}
/* Compute L - Q'*A */
zgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("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 */
zlaset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
zherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of ZQLT01 */
} /* zqlt01_ */
