/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
doublecomplex *work, integer *nwork, doublereal *rwork, integer *
iwork, logical *select, doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
doublereal ulp, cond;
integer jcol, nmax;
doublereal unfl, ovfl, temp1, temp2;
logical badnn, match;
integer imode;
doublereal dumma[4];
integer iinfo;
doublereal conds;
extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *);
doublereal aninv, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublecomplex cdumma[4];
integer idumma[1];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
char *, integer *, integer *, integer *), zlatme_(integer
*, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, char *, char *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
doublereal rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrevc_(char
*, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zunmhr_(char *, char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* ZGEHRD factors A as U H U' , where ' means conjugate */
/* transpose, H is hessenberg, and U is unitary. */
/* ZUNGHR generates the unitary matrix U. */
/* ZUNMHR multiplies a matrix by the unitary matrix U. */
/* ZHSEQR factors H as Z T Z' , where Z is unitary and T */
/* is upper triangular. It also computes the eigenvalues, */
/* w(1), ..., w(n); we define a diagonal matrix W whose */
/* (diagonal) entries are the eigenvalues. */
/* ZTREVC computes the left eigenvector matrix L and the */
/* right eigenvector matrix R for the matrix T. The */
/* columns of L are the complex conjugates of the left */
/* eigenvectors of T. The columns of R are the right */
/* eigenvectors of T. L is lower triangular, and R is */
/* upper triangular. */
/* ZHSEIN computes the left eigenvector matrix Y and the */
/* right eigenvector matrix X for the matrix H. The */
/* columns of Y are the complex conjugates of the left */
/* eigenvectors of H. The columns of X are the right */
/* eigenvectors of H. Y is lower triangular, and X is */
/* upper triangular. */
/* When ZCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**H | / ( |A| n ulp ) */
/* (2) | I - UU**H | / ( n ulp ) */
/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
/* (4) | I - ZZ**H | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by ZGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by ZHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by ZHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZGEHRD. */
/* Modified. */
/* Z - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZHSEQR. */
/* Modified. */
/* UZ - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* W1 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a full Schur */
/* decomposition H = Z T Z'. On exit, W1 contains the */
/* eigenvalues of the matrix in A. */
/* Modified. */
/* W3 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a partial Schur */
/* decomposition (Z not computed, T only computed as much */
/* as is necessary for determining eigenvalues). On exit, */
/* W3 contains the eigenvalues of the matrix in A, possibly */
/* perturbed by ZHSEIN. */
/* Modified. */
/* EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the (upper triangular) left */
/* eigenvector matrix for the matrix in T1. */
/* Modified. */
/* EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. */
/* Modified. */
/* EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the left eigenvector matrix */
/* for the matrix in H. */
/* Modified. */
/* EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the matrix in H. */
/* Modified. */
/* UU - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* Details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* TAU - COMPLEX*16 array, dimension (max(NN)) */
/* Further details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* WORK - COMPLEX*16 array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* RWORK - DOUBLE PRECISION array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
/* Modified. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
/* Modified. */
/* RESULT - DOUBLE PRECISION array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -26: NWORK too small. */
/* If ZLATMR, CLATMS, or CLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then ZHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by DLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--w1;
--w3;
--tau;
--work;
--rwork;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L250;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call ZGEHRD to compute H and U, do tests. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "ZGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + 1 + j * uu_dim1;
uu[i__4].r = 0., uu[i__4].i = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = i__ + j * u_dim1;
i__6 = i__ + j * h_dim1;
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = i__ + j * uu_dim1;
i__6 = i__ + j * h_dim1;
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = i__ + j * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
zcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call ZHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (W3) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Compute Z = U' UZ */
zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[1], &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2),
d__2 = z_abs(&w3[j]);
temp1 = max(d__1,d__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[
i__5].i;
d__1 = temp2, d__2 = z_abs(&z__1);
temp2 = max(d__1,d__2);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectr_dim1;
i__6 = jj + k * evectl_dim1;
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectl_dim1;
i__6 = jj + k * evectr_dim1;
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call ZHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L220: */
}
zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call ZUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
dlasum_("ZHS", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHS */
} /* zchkhs_ */
/* Subroutine */ int zchkbb_(integer *nsizes, integer *mval, integer *nval,
integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
integer *nrhs, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *ab, integer *ldab,
doublereal *bd, doublereal *be, doublecomplex *q, integer *ldq,
doublecomplex *p, integer *ldp, doublecomplex *c__, integer *ldc,
doublecomplex *cc, doublecomplex *work, integer *lwork, doublereal *
rwork, doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKBB: \002,a,\002 returned INFO=\002,i"
"5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
"3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
"(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, m, n, kl, jr, ku;
doublereal ulp, cond;
integer jcol, kmax, mmax, nmax;
doublereal unfl, ovfl;
logical badmm, badnn;
integer imode, iinfo;
extern /* Subroutine */ int zbdt01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublereal *, doublereal *), zbdt02_(integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *);
doublereal anorm;
integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int dlahd2_(integer *, char *), zunt01_(
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *);
logical badnnb;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgbbrd_(char *, integer *, integer *, integer
*, integer *, integer *, doublecomplex *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, integer *);
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*);
doublereal amninv;
integer jwidth;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
doublereal rtunfl, rtovfl, ulpinv;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (new routine for release 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKBB tests the reduction of a general complex rectangular band */
/* matrix to real bidiagonal form. */
/* ZGBBRD factors a general band matrix A as Q B P* , where * means */
/* conjugate transpose, B is upper bidiagonal, and Q and P are unitary; */
/* ZGBBRD can also overwrite a given matrix C with Q* C . */
/* For each pair of matrix dimensions (M,N) and each selected matrix */
/* type, an M by N matrix A and an M by NRHS matrix C are generated. */
/* The problem dimensions are as follows */
/* A: M x N */
/* Q: M x M */
/* P: N x N */
/* B: min(M,N) x min(M,N) */
/* C: M x NRHS */
/* For each generated matrix, 4 tests are performed: */
/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
/* (2) | I - Q' Q | / ( M ulp ) */
/* (3) | I - PT PT' | / ( N ulp ) */
/* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* The possible matrix types are */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U D V, where U and V are orthogonal and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U D V, where U and V are orthogonal and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U D V, where U and V are orthogonal and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Rectangular matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of values of M and N contained in the vectors */
/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
/* If NSIZES is zero, ZCHKBB does nothing. NSIZES must be at */
/* least zero. */
/* MVAL (input) INTEGER array, dimension (NSIZES) */
/* The values of the matrix row dimension M. */
/* NVAL (input) INTEGER array, dimension (NSIZES) */
/* The values of the matrix column dimension N. */
/* NWDTHS (input) INTEGER */
/* The number of bandwidths to use. If it is zero, */
/* ZCHKBB does nothing. It must be at least zero. */
/* KK (input) INTEGER array, dimension (NWDTHS) */
/* An array containing the bandwidths to be used for the band */
/* matrices. The values must be at least zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKBB */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* NRHS (input) INTEGER */
/* The number of columns in the "right-hand side" matrix C. */
/* If NRHS = 0, then the operations on the right-hand side will */
/* not be tested. NRHS must be at least 0. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKBB to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) DOUBLE PRECISION array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least max( NN ). */
/* AB (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN)) */
/* Used to hold A in band storage format. */
/* LDAB (input) INTEGER */
/* The leading dimension of AB. It must be at least 2 (not 1!) */
/* and at least max( KK )+1. */
/* BD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the diagonal of the bidiagonal matrix computed */
/* by ZGBBRD. */
/* BE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the bidiagonal matrix */
/* computed by ZGBBRD. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* Used to hold the unitary matrix Q computed by ZGBBRD. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q. It must be at least 1 */
/* and at least max( NN ). */
/* P (workspace) COMPLEX*16 array, dimension (LDP, max(NN)) */
/* Used to hold the unitary matrix P computed by ZGBBRD. */
/* LDP (input) INTEGER */
/* The leading dimension of P. It must be at least 1 */
/* and at least max( NN ). */
/* C (workspace) COMPLEX*16 array, dimension (LDC, max(NN)) */
/* Used to hold the matrix C updated by ZGBBRD. */
/* LDC (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* CC (workspace) COMPLEX*16 array, dimension (LDC, max(NN)) */
/* Used to hold a copy of the matrix C. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max( LDA+1, max(NN)+1 )*max(NN). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* NTESTT The total number of tests performed so far. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far. */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--mval;
--nval;
--kk;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--bd;
--be;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
p_dim1 = *ldp;
p_offset = 1 + p_dim1;
p -= p_offset;
cc_dim1 = *ldc;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
/* Important constants */
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mval[j];
mmax = max(i__2,i__3);
if (mval[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nval[j];
nmax = max(i__2,i__3);
if (nval[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX */
/* Computing MIN */
i__4 = mval[j], i__5 = nval[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* L10: */
}
badnnb = FALSE_;
kmax = 0;
i__1 = *nwdths;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kmax, i__3 = kk[j];
kmax = max(i__2,i__3);
if (kk[j] < 0) {
badnnb = TRUE_;
}
/* L20: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*nwdths < 0) {
*info = -4;
} else if (badnnb) {
*info = -5;
} else if (*ntypes < 0) {
*info = -6;
} else if (*nrhs < 0) {
*info = -8;
} else if (*lda < nmax) {
*info = -13;
} else if (*ldab < (kmax << 1) + 1) {
*info = -15;
} else if (*ldq < nmax) {
*info = -19;
} else if (*ldp < nmax) {
*info = -21;
} else if (*ldc < nmax) {
*info = -23;
} else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKBB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
/* Loop over sizes, widths, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mval[jsize];
n = nval[jsize];
mnmin = min(m,n);
/* Computing MAX */
i__2 = max(1,m);
amninv = 1. / (doublereal) max(i__2,n);
i__2 = *nwdths;
for (jwidth = 1; jwidth <= i__2; ++jwidth) {
k = kk[jwidth];
if (k >= m && k >= n) {
goto L150;
}
/* Computing MAX */
/* Computing MIN */
i__5 = m - 1;
i__3 = 0, i__4 = min(i__5,k);
kl = max(i__3,i__4);
/* Computing MAX */
/* Computing MIN */
i__5 = n - 1;
i__3 = 0, i__4 = min(i__5,k);
ku = max(i__3,i__4);
if (*nsizes != 1) {
mtypes = min(15,*ntypes);
} else {
mtypes = min(16,*ntypes);
}
i__3 = mtypes;
for (jtype = 1; jtype <= i__3; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
++nmats;
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L30: */
}
/* Compute "A". */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ singular values) */
/* =5 random log (none) */
/* =6 random nonhermitian, w/ singular values */
/* =7 (none) */
/* =8 (none) */
/* =9 random nonhermitian */
if (mtypes > 15) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
zlaset_("Full", ldab, &n, &c_b1, &c_b1, &ab[ab_offset], ldab);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__4 = n;
for (jcol = 1; jcol <= i__4; ++jcol) {
i__5 = jcol + jcol * a_dim1;
a[i__5].r = anorm, a[i__5].i = 0.;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, singular values specified */
zlatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[1], &iinfo);
} else if (itype == 6) {
/* Nonhermitian, singular values specified */
zlatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
work[1], &iinfo);
} else if (itype == 9) {
/* Nonhermitian, random entries */
zlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
c_b33, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b33, &work[(n << 1) + 1], &c__1, &c_b33, "N",
idumma, &kl, &ku, &c_b41, &anorm, "N", &a[
a_offset], lda, idumma, &iinfo);
} else {
iinfo = 1;
}
/* Generate Right-Hand Side */
zlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b33, &c_b2, "T", "N", &work[m + 1], &c__1, &c_b33, &
work[(m << 1) + 1], &c__1, &c_b33, "N", idumma, &m,
nrhs, &c_b41, &c_b33, "NO", &c__[c_offset], ldc,
idumma, &iinfo);
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Copy A to band storage. */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__5 = 1, i__6 = j - ku;
/* Computing MIN */
i__8 = m, i__9 = j + kl;
i__7 = min(i__8,i__9);
for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
i__5 = ku + 1 + i__ - j + j * ab_dim1;
i__6 = i__ + j * a_dim1;
ab[i__5].r = a[i__6].r, ab[i__5].i = a[i__6].i;
/* L100: */
}
/* L110: */
}
/* Copy C */
zlacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
ldc);
/* Call ZGBBRD to compute B, Q and P, and to update C. */
zgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
cc[cc_offset], ldc, &work[1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "ZGBBRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[1] = ulpinv;
goto L120;
}
}
/* Test 1: Check the decomposition A := Q * B * P' */
/* 2: Check the orthogonality of Q */
/* 3: Check the orthogonality of P */
/* 4: Check the computation of Q' * C */
zbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &p[p_offset], ldp, &work[1], &rwork[1],
&result[1]);
zunt01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
&rwork[1], &result[2]);
zunt01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
rwork[1], &result[3]);
zbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
q[q_offset], ldq, &work[1], &rwork[1], &result[4]);
/* End of Loop -- Check for RESULT(j) > THRESH */
ntest = 4;
L120:
ntestt += ntest;
/* Print out tests which fail. */
i__4 = ntest;
for (jr = 1; jr <= i__4; ++jr) {
if (result[jr] >= *thresh) {
if (nerrs == 0) {
dlahd2_(nounit, "ZBB");
}
++nerrs;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L130: */
}
L140:
;
}
L150:
;
}
/* L160: */
}
/* Summary */
dlasum_("ZBB", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKBB */
} /* zchkbb_ */
/* Subroutine */ int zdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
doublecomplex *af, doublecomplex *b, doublecomplex *x, doublecomplex *
xact, doublecomplex *work, doublereal *rwork, integer *iwork, integer
*nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
" ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
doublereal d__1, d__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static doublereal cond;
static integer mode, koff, imat, info;
static char path[3], dist[1], type__[1];
static integer nrun, i__, j, k, m, n, ifact, nfail, iseed[4];
static doublereal z__[3];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
static doublereal anorm;
static integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static char trans[1];
static integer izero, nerrs;
extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *);
static integer k1;
extern /* Subroutine */ int zgtt02_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublecomplex *, integer *, doublereal *, doublereal
*), zgtt05_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgtsv_(integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, integer *), zlatb4_(char *, integer *, integer *,
integer *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix, nt;
static doublereal rcondc, rcondi;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *);
static doublereal rcondo, anormi, ainvnm;
static logical trfcon;
static doublereal anormo;
extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *);
extern doublereal zlangt_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *), zlarnv_(integer *, integer *,
integer *, doublecomplex *);
static doublereal result[6];
extern /* Subroutine */ int zgttrf_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
integer *), zgttrs_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), zerrvx_(char *,
integer *), zgtsvx_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, doublecomplex *,
doublereal *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZDRVGT tests ZGTSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
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.
A (workspace) COMPLEX*16 array, dimension (NMAX*4)
AF (workspace) COMPLEX*16 array, dimension (NMAX*4)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number.
Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with
unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
zlarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.) {
i__3 = n + (m << 1);
zdscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1], a[i__3].i = 0.;
if (n > 1) {
a[1].r = z__[2], a[1].i = 0.;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0], a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1], a[i__3].i = 0.;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0], a[i__3].i = 0.;
i__3 = n - 1 + izero;
a[i__3].r = z__[1], a[i__3].i = 0.;
i__3 = izero;
a[i__3].r = z__[2], a[i__3].i = 0.;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1] = a[i__3].r;
i__3 = n;
a[i__3].r = 0., a[i__3].i = 0.;
if (n > 1) {
z__[2] = a[1].r;
a[1].r = 0., a[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0] = a[i__3].r;
i__3 = (n << 1) - 1;
z__[1] = a[i__3].r;
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = n - 1 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with
the value returned by ZGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.;
rcondi = 0.;
} else if (ifact == 1) {
i__3 = n + (m << 1);
zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = zlangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = zlangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use ZGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0. || ainvnm <= 0.) {
rcondo = 1.;
} else {
rcondo = 1. / anormo / ainvnm;
}
/* Use ZGTTRS to solve for one column at a time of
inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
&iwork[1], &x[1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
zlagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test ZGTSV ---
Solve the system using Gaussian elimination with
partial pivoting. */
i__3 = n + (m << 1);
zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZGTSV ", (ftnlen)6, (ftnlen)
6);
zgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from ZGTSV . */
if (info != izero) {
alaerh_(path, "ZGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
zgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "ZGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test ZGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
af[i__4].r = 0., af[i__4].i = 0.;
/* L90: */
}
}
zlaset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using ZGTSVX. */
s_copy(srnamc_1.srnamt, "ZGTSVX", (ftnlen)6, (ftnlen)6);
zgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from ZGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "ZGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
zgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "ZGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = dget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "ZGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVGT */
} /* zdrvgt_ */
/* Subroutine */ int zdrvpb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
" \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
",i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer ldab;
static char fact[1];
static integer ioff, mode, koff;
static doublereal amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact, nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
static integer kdval[4];
extern logical lsame_(char *, char *);
static char equed[1];
static integer nbmin;
static doublereal rcond, roldc, scond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static logical equil;
extern /* Subroutine */ int zpbt01_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zpbt02_(char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zpbt05_(char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static integer iuplo, izero, i1, i2, k1, nerrs;
static logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zpbsv_(char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *), zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static char xtype[1];
extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *);
static integer kd, nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static logical prefac;
static integer iw, ku, nt;
static doublereal rcondc;
static logical nofact;
static char packit[1];
static integer iequed;
extern doublereal zlanhb_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *),
zlange_(char *, integer *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zlaqhb_(char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *, char *), alasvm_(char *, integer *,
integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
static doublereal ainvnm;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zpbequ_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *, integer *), zpbtrf_(char *, integer *, integer *, doublecomplex *,
integer *, integer *), zlatms_(integer *, integer *, char
*, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
integer *), zpbsvx_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
char *, doublereal *, doublecomplex *, integer *, doublecomplex *
, integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *),
zerrvx_(char *, integer *);
static integer lda, ikd, nkd;
/* Fortran I/O blocks */
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZDRVPB tests the driver routines ZPBSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
S (workspace) DOUBLE PRECISION array, dimension (NMAX)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
kdval[0] = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations.
Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
makes it easier to skip redundant values for small values
of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'Q';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L80;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with ZLATB4 and generate a test
matrix with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)
6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &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 L80;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type
2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
zcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
zcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix
to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = iw + i__;
work[i__5].r = 0., work[i__5].i = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
zswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
zswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
zswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
zswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
zlaipd_(&n, &a[kd + 1], &ldab, &c__0);
} else {
zlaipd_(&n, &a[1], &ldab, &c__0);
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
zlacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__4 = nfact;
for (ifact = 1; ifact <= i__4; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondc = 0.;
} else if (! lsame_(fact, "N")) {
/* Compute the condition number for comparison
with the value returned by ZPBSVX (FACT =
'N' reuses the condition number from the
previous iteration with FACT = 'F'). */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &
afac[1], &ldab);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
zpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
s[1], &scond, &amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
zlaqhb_(uplo, &n, &kd, &afac[1], &
ldab, &s[1], &scond, &amax,
equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in ZGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = zlanhb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
zpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
zlaset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)6, (
ftnlen)6);
zpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlange_("1", &n, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
&ldab);
/* Form an exact solution and set the right hand
side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (
ftnlen)6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
&lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
lda);
if (nofact) {
/* --- Test ZPBSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "ZPBSV ", (ftnlen)6, (
ftnlen)6);
zpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from ZPBSV . */
if (info != izero) {
alaerh_(path, "ZPBSV ", &info, &izero,
uplo, &n, &n, &kd, &kd, nrhs, &
imat, &nfail, &nerrs, nout);
goto L40;
} else if (info != 0) {
goto L40;
}
/* Reconstruct matrix from factors and compute
residual. */
zpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
zpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did
not pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___57.ciunit = *nout;
s_wsfe(&io___57);
do_fio(&c__1, "ZPBSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (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;
}
/* L30: */
}
nrun += nt;
L40:
;
}
/* --- Test ZPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
zlaset_("Full", &i__5, &n, &c_b47, &c_b47, &
afac[1], &ldab);
}
zlaset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y' */
zlaqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition
number and error bounds using ZPBSVX. */
s_copy(srnamc_1.srnamt, "ZPBSVX", (ftnlen)6, (
ftnlen)6);
zpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
afac[1], &ldab, equed, &s[1], &b[1], &lda,
&x[1], &lda, &rcond, &rwork[1], &rwork[*
nrhs + 1], &work[1], &rwork[(*nrhs << 1)
+ 1], &info);
/* Check the error code from ZPBSVX. */
if (info != izero) {
/* Writing concatenation */
i__7[0] = 1, a__1[0] = fact;
i__7[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
alaerh_(path, "ZPBSVX", &info, &izero, ch__1,
&n, &n, &kd, &kd, nrhs, &imat, &nfail,
&nerrs, nout);
goto L60;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and
compute residual. */
zpbt01_(uplo, &n, &kd, &a[1], &ldab, &
afac[1], &ldab, &rwork[(*nrhs <<
1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
zpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&x[1], &lda, &work[1], &lda, &rwork[(*
nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &rcondc, &result[2]);
} else {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
zpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&b[1], &lda, &x[1], &lda, &xact[1], &
lda, &rwork[1], &rwork[*nrhs + 1], &
result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from ZPBSVX with the computed
value in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not
pass the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___60.ciunit = *nout;
s_wsfe(&io___60);
do_fio(&c__1, "ZPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "ZPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (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;
}
/* L50: */
}
nrun = nrun + 7 - k1;
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* L100: */
}
/* L110: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPB */
} /* zdrvpb_ */
/* Subroutine */ int zckgqr_(integer *nm, integer *mval, integer *np, integer
*pval, integer *nn, integer *nval, integer *nmats, integer *iseed,
doublereal *thresh, integer *nmax, doublecomplex *a, doublecomplex *
af, doublecomplex *aq, doublecomplex *ar, doublecomplex *taua,
doublecomplex *b, doublecomplex *bf, doublecomplex *bz, doublecomplex
*bt, doublecomplex *bwk, doublecomplex *taub, doublecomplex *work,
doublereal *rwork, integer *nin, integer *nout, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZLATMS in ZCKGQR: INFO = \002,i5)";
static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
char path[3];
integer imat;
char type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
doublereal anorm, bnorm;
integer lwork;
extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
*, integer *, char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, char *, char *),
alahdg_(integer *, char *);
doublereal cndnma, cndnmb;
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *);
logical dotype[8];
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
logical firstt;
doublereal result[7];
extern /* Subroutine */ int zgqrts_(integer *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublereal *,
doublereal *), zgrqts_(integer *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublereal *,
doublereal *);
/* Fortran I/O blocks */
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCKGQR tests */
/* ZGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
/* ZGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
/* Arguments */
/* ========= */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row(column) dimension M. */
/* NP (input) INTEGER */
/* The number of values of P contained in the vector PVAL. */
/* PVAL (input) INTEGER array, dimension (NP) */
/* The values of the matrix row(column) dimension P. */
/* 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 column(row) dimension N. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AR (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* TAUA (workspace) COMPLEX*16 array, dimension (NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BZ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BT (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BWK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* TAUB (workspace) COMPLEX*16 array, dimension (NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NIN (input) INTEGER */
/* The unit number for input. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* > 0 : If ZLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants. */
/* Parameter adjustments */
--rwork;
--work;
--taub;
--bwk;
--bt;
--bz;
--bf;
--b;
--taua;
--ar;
--aq;
--af;
--a;
--iseed;
--nval;
--pval;
--mval;
/* Function Body */
s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
lwork = *nmax * *nmax;
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of P in PVAL. */
i__2 = *np;
for (ip = 1; ip <= i__2; ++ip) {
p = pval[ip];
/* Do for each value of N in NVAL. */
i__3 = *nn;
for (in = 1; in <= i__3; ++in) {
n = nval[in];
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L30;
}
/* Test ZGGRQF */
/* Set up parameters with DLATB9 and generate test */
/* matrices A and B with ZLATMS. */
dlatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
klb, &kub, &anorm, &bnorm, &modea, &modeb, &
cndnma, &cndnmb, dista, distb);
zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
modea, &cndnma, &anorm, &kla, &kua, "No packing",
&a[1], &lda, &work[1], &iinfo);
if (iinfo != 0) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L30;
}
zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
modeb, &cndnmb, &bnorm, &klb, &kub, "No packing",
&b[1], &ldb, &work[1], &iinfo);
if (iinfo != 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L30;
}
nt = 4;
zgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
ldb, &taub[1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (i__ = 1; i__ <= i__4; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, "GRQ");
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L10: */
}
nrun += nt;
/* Test ZGGQRF */
/* Set up parameters with DLATB9 and generate test */
/* matrices A and B with ZLATMS. */
dlatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
klb, &kub, &anorm, &bnorm, &modea, &modeb, &
cndnma, &cndnmb, dista, distb);
zlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
modea, &cndnma, &anorm, &kla, &kua, "No packing",
&a[1], &lda, &work[1], &iinfo);
if (iinfo != 0) {
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L30;
}
zlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
modea, &cndnma, &bnorm, &klb, &kub, "No packing",
&b[1], &ldb, &work[1], &iinfo);
if (iinfo != 0) {
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L30;
}
nt = 4;
zgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
ldb, &taub[1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (i__ = 1; i__ <= i__4; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of ZCKGQR */
} /* zckgqr_ */
/* Subroutine */ int zchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, info;
static char path[3];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, nfail, iseed[4], imode, mnmin, nerrs, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt01_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt02_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztzrzf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
static integer lda;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZCHKTZ tests ZTZRQF and ZTZRZF.
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.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
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 column dimension N.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) COMPLEX*16 array, dimension (MMAX)
WORK (workspace) COMPLEX*16 array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n;
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
/* Do for each type of singular value distribution.
0: zero matrix
1: one small singular value
2: exponential distribution */
mode = imode - 1;
/* Test ZTZRQF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L20: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRQF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6);
ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test ZTZRZF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRZF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6);
ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = zrzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass
the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (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;
}
/* L40: */
}
nrun += 6;
/* L50: */
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if ZCHKTZ */
return 0;
} /* zchktz_ */
/* Subroutine */ int zchkhp_(logical *dotype, integer *nn, integer *nval,
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, "
"type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal rcond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zhpt01_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *);
integer iuplo, izero, nerrs;
extern /* Subroutine */ int zppt02_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zppt03_(char *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
char xtype[1];
extern /* Subroutine */ int 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;
char packit[1];
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
logical trfcon;
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *, 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 *),
zhprfs_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *), zhptrf_(char *,
integer *, doublecomplex *, integer *, integer *);
doublereal result[8];
extern /* Subroutine */ int zhptri_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zhptrs_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *), zerrsy_(char *, integer *)
;
/* Fortran I/O blocks */
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHP tests ZHPTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) 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+1)/2) */
/* AFAC (workspace) COMPLEX*16 array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) COMPLEX*16 array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* 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;
--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, "HP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
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 = 10;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L160;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L160;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)packit = 'R';
}
/* Set up parameters with 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, packit, &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 L150;
}
/* For types 3-6, zero one or more rows and columns of */
/* the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., 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 += i__;
/* 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 = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L60: */
}
ioff += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L80: */
}
ioff = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
zlaipd_(&n, &a[1], &c__2, &c__1);
} else {
zlaipd_(&n, &a[1], &n, &c_n1);
}
/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
npp = n * (n + 1) / 2;
zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "ZHPTRF", (ftnlen)6, (ftnlen)6);
zhptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from ZHPTRF. */
if (info != k) {
alaerh_(path, "ZHPTRF", &info, &k, uplo, &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
zhpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
&rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse and compute the residual. */
if (! trfcon) {
zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "ZHPTRI", (ftnlen)6, (ftnlen)6);
zhptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
/* Check error code from ZHPTRI. */
if (info != 0) {
alaerh_(path, "ZHPTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
zppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
1], &rcondc, &result[1]);
nt = 2;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.;
goto L140;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZHPTRS", (ftnlen)6, (ftnlen)6);
zhptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from ZHPTRS. */
if (info != 0) {
alaerh_(path, "ZHPTRS", &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);
zppt02_(uplo, &n, &nrhs, &a[1], &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, "ZHPRFS", (ftnlen)6, (ftnlen)6);
zhprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
&work[1], &rwork[(nrhs << 1) + 1], &info);
/* Check error code from ZHPRFS. */
if (info != 0) {
alaerh_(path, "ZHPRFS", &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]);
zppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
&xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "ZHPCON", (ftnlen)6, (ftnlen)6);
zhpcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
1], &info);
/* Check error code from ZHPCON. */
if (info != 0) {
alaerh_(path, "ZHPCON", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
/* L170: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKHP */
} /* zchkhp_ */
main(int argc, char *argv[])
{
/*
* Purpose
* =======
*
* ZDRIVE is the main test program for the DOUBLE COMPLEX linear
* equation driver routines ZGSSV and ZGSSVX.
*
* The program is invoked by a shell script file -- ztest.csh.
* The output from the tests are written into a file -- ztest.out.
*
* =====================================================================
*/
doublecomplex *a, *a_save;
int *asub, *asub_save;
int *xa, *xa_save;
SuperMatrix A, B, X, L, U;
SuperMatrix ASAV, AC;
mem_usage_t mem_usage;
int *perm_r; /* row permutation from partial pivoting */
int *perm_c, *pc_save; /* column permutation */
int *etree;
doublecomplex zero = {0.0, 0.0};
double *R, *C;
double *ferr, *berr;
double *rwork;
doublecomplex *wwork;
void *work;
int info, lwork, nrhs, panel_size, relax;
int m, n, nnz;
doublecomplex *xact;
doublecomplex *rhsb, *solx, *bsav;
int ldb, ldx;
double rpg, rcond;
int i, j, k1;
double rowcnd, colcnd, amax;
int maxsuper, rowblk, colblk;
int prefact, nofact, equil, iequed;
int nt, nrun, nfail, nerrs, imat, fimat, nimat;
int nfact, ifact, itran;
int kl, ku, mode, lda;
int zerot, izero, ioff;
double u;
double anorm, cndnum;
doublecomplex *Afull;
double result[NTESTS];
superlu_options_t options;
fact_t fact;
trans_t trans;
SuperLUStat_t stat;
static char matrix_type[8];
static char equed[1], path[4], sym[1], dist[1];
/* Fixed set of parameters */
int iseed[] = {1988, 1989, 1990, 1991};
static char equeds[] = {'N', 'R', 'C', 'B'};
static fact_t facts[] = {FACTORED, DOFACT, SamePattern,
SamePattern_SameRowPerm};
static trans_t transs[] = {NOTRANS, TRANS, CONJ};
/* Some function prototypes */
extern int zgst01(int, int, SuperMatrix *, SuperMatrix *,
SuperMatrix *, int *, int *, double *);
extern int zgst02(trans_t, int, int, int, SuperMatrix *, doublecomplex *,
int, doublecomplex *, int, double *resid);
extern int zgst04(int, int, doublecomplex *, int,
doublecomplex *, int, double rcond, double *resid);
extern int zgst07(trans_t, int, int, SuperMatrix *, doublecomplex *, int,
doublecomplex *, int, doublecomplex *, int,
double *, double *, double *);
extern int zlatb4_(char *, int *, int *, int *, char *, int *, int *,
double *, int *, double *, char *);
extern int zlatms_(int *, int *, char *, int *, char *, double *d,
int *, double *, double *, int *, int *,
char *, doublecomplex *, int *, doublecomplex *, int *);
extern int sp_zconvert(int, int, doublecomplex *, int, int, int,
doublecomplex *a, int *, int *, int *);
/* Executable statements */
strcpy(path, "ZGE");
nrun = 0;
nfail = 0;
nerrs = 0;
/* Defaults */
lwork = 0;
n = 1;
nrhs = 1;
panel_size = sp_ienv(1);
relax = sp_ienv(2);
u = 1.0;
strcpy(matrix_type, "LA");
parse_command_line(argc, argv, matrix_type, &n,
&panel_size, &relax, &nrhs, &maxsuper,
&rowblk, &colblk, &lwork, &u);
if ( lwork > 0 ) {
work = SUPERLU_MALLOC(lwork);
if ( !work ) {
fprintf(stderr, "expert: cannot allocate %d bytes\n", lwork);
exit (-1);
}
}
/* Set the default input options. */
set_default_options(&options);
options.DiagPivotThresh = u;
options.PrintStat = NO;
options.PivotGrowth = YES;
options.ConditionNumber = YES;
options.IterRefine = DOUBLE;
if ( strcmp(matrix_type, "LA") == 0 ) {
/* Test LAPACK matrix suite. */
m = n;
lda = SUPERLU_MAX(n, 1);
nnz = n * n; /* upper bound */
fimat = 1;
nimat = NTYPES;
Afull = doublecomplexCalloc(lda * n);
zallocateA(n, nnz, &a, &asub, &xa);
} else {
/* Read a sparse matrix */
fimat = nimat = 0;
zreadhb(&m, &n, &nnz, &a, &asub, &xa);
}
zallocateA(n, nnz, &a_save, &asub_save, &xa_save);
rhsb = doublecomplexMalloc(m * nrhs);
bsav = doublecomplexMalloc(m * nrhs);
solx = doublecomplexMalloc(n * nrhs);
ldb = m;
ldx = n;
zCreate_Dense_Matrix(&B, m, nrhs, rhsb, ldb, SLU_DN, SLU_Z, SLU_GE);
zCreate_Dense_Matrix(&X, n, nrhs, solx, ldx, SLU_DN, SLU_Z, SLU_GE);
xact = doublecomplexMalloc(n * nrhs);
etree = intMalloc(n);
perm_r = intMalloc(n);
perm_c = intMalloc(n);
pc_save = intMalloc(n);
R = (double *) SUPERLU_MALLOC(m*sizeof(double));
C = (double *) SUPERLU_MALLOC(n*sizeof(double));
ferr = (double *) SUPERLU_MALLOC(nrhs*sizeof(double));
berr = (double *) SUPERLU_MALLOC(nrhs*sizeof(double));
j = SUPERLU_MAX(m,n) * SUPERLU_MAX(4,nrhs);
rwork = (double *) SUPERLU_MALLOC(j*sizeof(double));
for (i = 0; i < j; ++i) rwork[i] = 0.;
if ( !R ) ABORT("SUPERLU_MALLOC fails for R");
if ( !C ) ABORT("SUPERLU_MALLOC fails for C");
if ( !ferr ) ABORT("SUPERLU_MALLOC fails for ferr");
if ( !berr ) ABORT("SUPERLU_MALLOC fails for berr");
if ( !rwork ) ABORT("SUPERLU_MALLOC fails for rwork");
wwork = doublecomplexCalloc( SUPERLU_MAX(m,n) * SUPERLU_MAX(4,nrhs) );
for (i = 0; i < n; ++i) perm_c[i] = pc_save[i] = i;
options.ColPerm = MY_PERMC;
for (imat = fimat; imat <= nimat; ++imat) { /* All matrix types */
if ( imat ) {
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = (imat >= 5 && imat <= 7);
if ( zerot && n < imat-4 )
continue;
/* Set up parameters with ZLATB4 and generate a test matrix
with ZLATMS. */
zlatb4_(path, &imat, &n, &n, sym, &kl, &ku, &anorm, &mode,
&cndnum, dist);
zlatms_(&n, &n, dist, iseed, sym, &rwork[0], &mode, &cndnum,
&anorm, &kl, &ku, "No packing", Afull, &lda,
&wwork[0], &info);
if ( info ) {
printf(FMT3, "ZLATMS", info, izero, n, nrhs, imat, nfail);
continue;
}
/* For types 5-7, zero one or more columns of the matrix
to test that INFO is returned correctly. */
if ( zerot ) {
if ( imat == 5 ) izero = 1;
else if ( imat == 6 ) izero = n;
else izero = n / 2 + 1;
ioff = (izero - 1) * lda;
if ( imat < 7 ) {
for (i = 0; i < n; ++i) Afull[ioff + i] = zero;
} else {
for (j = 0; j < n - izero + 1; ++j)
for (i = 0; i < n; ++i)
Afull[ioff + i + j*lda] = zero;
}
} else {
izero = 0;
}
/* Convert to sparse representation. */
sp_zconvert(n, n, Afull, lda, kl, ku, a, asub, xa, &nnz);
} else {
izero = 0;
zerot = 0;
}
zCreate_CompCol_Matrix(&A, m, n, nnz, a, asub, xa, SLU_NC, SLU_Z, SLU_GE);
/* Save a copy of matrix A in ASAV */
zCreate_CompCol_Matrix(&ASAV, m, n, nnz, a_save, asub_save, xa_save,
SLU_NC, SLU_Z, SLU_GE);
zCopy_CompCol_Matrix(&A, &ASAV);
/* Form exact solution. */
zGenXtrue(n, nrhs, xact, ldx);
StatInit(&stat);
for (iequed = 0; iequed < 4; ++iequed) {
*equed = equeds[iequed];
if (iequed == 0) nfact = 4;
else nfact = 1; /* Only test factored, pre-equilibrated matrix */
for (ifact = 0; ifact < nfact; ++ifact) {
fact = facts[ifact];
options.Fact = fact;
for (equil = 0; equil < 2; ++equil) {
options.Equil = equil;
prefact = ( options.Fact == FACTORED ||
options.Fact == SamePattern_SameRowPerm );
/* Need a first factor */
nofact = (options.Fact != FACTORED); /* Not factored */
/* Restore the matrix A. */
zCopy_CompCol_Matrix(&ASAV, &A);
if ( zerot ) {
if ( prefact ) continue;
} else if ( options.Fact == FACTORED ) {
if ( equil || iequed ) {
/* Compute row and column scale factors to
equilibrate matrix A. */
zgsequ(&A, R, C, &rowcnd, &colcnd, &amax, &info);
/* Force equilibration. */
if ( !info && n > 0 ) {
if ( lsame_(equed, "R") ) {
rowcnd = 0.;
colcnd = 1.;
} else if ( lsame_(equed, "C") ) {
rowcnd = 1.;
colcnd = 0.;
} else if ( lsame_(equed, "B") ) {
rowcnd = 0.;
colcnd = 0.;
}
}
/* Equilibrate the matrix. */
zlaqgs(&A, R, C, rowcnd, colcnd, amax, equed);
}
}
if ( prefact ) { /* Need a factor for the first time */
/* Save Fact option. */
fact = options.Fact;
options.Fact = DOFACT;
/* Preorder the matrix, obtain the column etree. */
sp_preorder(&options, &A, perm_c, etree, &AC);
/* Factor the matrix AC. */
zgstrf(&options, &AC, relax, panel_size,
etree, work, lwork, perm_c, perm_r, &L, &U,
&stat, &info);
if ( info ) {
printf("** First factor: info %d, equed %c\n",
info, *equed);
if ( lwork == -1 ) {
printf("** Estimated memory: %d bytes\n",
info - n);
exit(0);
}
}
Destroy_CompCol_Permuted(&AC);
/* Restore Fact option. */
options.Fact = fact;
} /* if .. first time factor */
for (itran = 0; itran < NTRAN; ++itran) {
trans = transs[itran];
options.Trans = trans;
/* Restore the matrix A. */
zCopy_CompCol_Matrix(&ASAV, &A);
/* Set the right hand side. */
zFillRHS(trans, nrhs, xact, ldx, &A, &B);
zCopy_Dense_Matrix(m, nrhs, rhsb, ldb, bsav, ldb);
/*----------------
* Test zgssv
*----------------*/
if ( options.Fact == DOFACT && itran == 0) {
/* Not yet factored, and untransposed */
zCopy_Dense_Matrix(m, nrhs, rhsb, ldb, solx, ldx);
zgssv(&options, &A, perm_c, perm_r, &L, &U, &X,
&stat, &info);
if ( info && info != izero ) {
printf(FMT3, "zgssv",
info, izero, n, nrhs, imat, nfail);
} else {
/* Reconstruct matrix from factors and
compute residual. */
zgst01(m, n, &A, &L, &U, perm_c, perm_r,
&result[0]);
nt = 1;
if ( izero == 0 ) {
/* Compute residual of the computed
solution. */
zCopy_Dense_Matrix(m, nrhs, rhsb, ldb,
wwork, ldb);
zgst02(trans, m, n, nrhs, &A, solx,
ldx, wwork,ldb, &result[1]);
nt = 2;
}
/* Print information about the tests that
did not pass the threshold. */
for (i = 0; i < nt; ++i) {
if ( result[i] >= THRESH ) {
printf(FMT1, "zgssv", n, i,
result[i]);
++nfail;
}
}
nrun += nt;
} /* else .. info == 0 */
/* Restore perm_c. */
for (i = 0; i < n; ++i) perm_c[i] = pc_save[i];
if (lwork == 0) {
Destroy_SuperNode_Matrix(&L);
Destroy_CompCol_Matrix(&U);
}
} /* if .. end of testing zgssv */
/*----------------
* Test zgssvx
*----------------*/
/* Equilibrate the matrix if fact = FACTORED and
equed = 'R', 'C', or 'B'. */
if ( options.Fact == FACTORED &&
(equil || iequed) && n > 0 ) {
zlaqgs(&A, R, C, rowcnd, colcnd, amax, equed);
}
/* Solve the system and compute the condition number
and error bounds using zgssvx. */
zgssvx(&options, &A, perm_c, perm_r, etree,
equed, R, C, &L, &U, work, lwork, &B, &X, &rpg,
&rcond, ferr, berr, &mem_usage, &stat, &info);
if ( info && info != izero ) {
printf(FMT3, "zgssvx",
info, izero, n, nrhs, imat, nfail);
if ( lwork == -1 ) {
printf("** Estimated memory: %.0f bytes\n",
mem_usage.total_needed);
exit(0);
}
} else {
if ( !prefact ) {
/* Reconstruct matrix from factors and
compute residual. */
zgst01(m, n, &A, &L, &U, perm_c, perm_r,
&result[0]);
k1 = 0;
} else {
k1 = 1;
}
if ( !info ) {
/* Compute residual of the computed solution.*/
zCopy_Dense_Matrix(m, nrhs, bsav, ldb,
wwork, ldb);
zgst02(trans, m, n, nrhs, &ASAV, solx, ldx,
wwork, ldb, &result[1]);
/* Check solution from generated exact
solution. */
zgst04(n, nrhs, solx, ldx, xact, ldx, rcond,
&result[2]);
/* Check the error bounds from iterative
refinement. */
zgst07(trans, n, nrhs, &ASAV, bsav, ldb,
solx, ldx, xact, ldx, ferr, berr,
&result[3]);
/* Print information about the tests that did
not pass the threshold. */
for (i = k1; i < NTESTS; ++i) {
if ( result[i] >= THRESH ) {
printf(FMT2, "zgssvx",
options.Fact, trans, *equed,
n, imat, i, result[i]);
++nfail;
}
}
nrun += NTESTS;
} /* if .. info == 0 */
} /* else .. end of testing zgssvx */
} /* for itran ... */
if ( lwork == 0 ) {
Destroy_SuperNode_Matrix(&L);
Destroy_CompCol_Matrix(&U);
}
} /* for equil ... */
} /* for ifact ... */
} /* for iequed ... */
#if 0
if ( !info ) {
PrintPerf(&L, &U, &mem_usage, rpg, rcond, ferr, berr, equed);
}
#endif
} /* for imat ... */
/* Print a summary of the results. */
PrintSumm("ZGE", nfail, nrun, nerrs);
SUPERLU_FREE (rhsb);
SUPERLU_FREE (bsav);
SUPERLU_FREE (solx);
SUPERLU_FREE (xact);
SUPERLU_FREE (etree);
SUPERLU_FREE (perm_r);
SUPERLU_FREE (perm_c);
SUPERLU_FREE (pc_save);
SUPERLU_FREE (R);
SUPERLU_FREE (C);
SUPERLU_FREE (ferr);
SUPERLU_FREE (berr);
SUPERLU_FREE (rwork);
SUPERLU_FREE (wwork);
Destroy_SuperMatrix_Store(&B);
Destroy_SuperMatrix_Store(&X);
Destroy_CompCol_Matrix(&A);
Destroy_CompCol_Matrix(&ASAV);
if ( lwork > 0 ) {
SUPERLU_FREE (work);
Destroy_SuperMatrix_Store(&L);
Destroy_SuperMatrix_Store(&U);
}
StatFree(&stat);
return 0;
}
/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w,
doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *
vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *
result, doublecomplex *work, integer *nwork, doublereal *rwork,
integer *iwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9993[] = "(\002 ZDRVEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR"
"VEV for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
"/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
"Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
"\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
"d.\002,\002 complx \002,a4)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
"lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
"computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
" matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
"0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
"e\002,/)";
static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
integer j, n, jj;
doublecomplex dum[1];
doublereal res[2];
integer iwk;
doublereal ulp, vmx, cond;
integer jcol;
char path[3];
integer nmax;
doublereal unfl, ovfl, tnrm, vrmx, vtst;
logical badnn;
integer nfail, imode, iinfo;
doublereal conds, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
integer jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*), zlatme_(integer *, char *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *, char *,
char *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
integer ntestf;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
char *, doublecomplex *, integer *, doublereal *, doublecomplex *
, integer *, doublereal *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal ulpinv;
integer nnwork, mtypes, ntestt;
doublereal rtulpi;
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV. */
/* When ZDRVEV is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate-transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when both VR and VL */
/* are also computed, and W(partial) denotes the eigenvalues */
/* computed when only W, only W and VR, or only W and VL are */
/* computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when both VR */
/* and VL are computed, and VR(partial) denotes the result */
/* when only VR is computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when both VR */
/* and VL are also computed, and VL(partial) denotes the result */
/* when only VL is computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZDRVEV does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZDRVEV */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZDRVEV to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max(NN). */
/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by ZGEEV. */
/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A. On exit, W are the eigenvalues of */
/* the matrix in A. */
/* W1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when ZGEEV only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN)). */
/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN)). */
/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 5*NN(j)+2*NN(j)**2 for all j. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) */
/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
/* -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
/* -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
/* -21: NWORK too small. */
/* If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code, */
/* the absolute value of it is returned. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--result;
--work;
--rwork;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*nounit <= 0) {
*info = -7;
} else if (*lda < 1 || *lda < nmax) {
*info = -9;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -14;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -16;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -28;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVEV", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 5 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = -1.;
/* L100: */
}
/* Compute eigenvalues and eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "ZGEEV1", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (1) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
ldvr, &w[1], &work[1], &rwork[1], res);
result[1] = res[0];
/* Do Test (2) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &w[1], &work[1], &rwork[1], res);
result[2] = res[0];
/* Do Test (3) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[3], d__3 = min(d__4,d__5);
result[3] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vr[jj + j * vr_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vr_dim1;
if (d_imag(&vr[jj + j * vr_dim1]) == 0. && (d__1 = vr[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vr_dim1;
vrmx = (d__2 = vr[i__6].r, abs(d__2));
}
/* L110: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[3] = ulpinv;
}
/* L120: */
}
/* Do Test (4) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
/* Computing MAX */
/* Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[4], d__3 = min(d__4,d__5);
result[4] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vl[jj + j * vl_dim1]);
if (vtst > vmx) {
vmx = vtst;
}
i__5 = jj + j * vl_dim1;
if (d_imag(&vl[jj + j * vl_dim1]) == 0. && (d__1 = vl[
i__5].r, abs(d__1)) > vrmx) {
i__6 = jj + j * vl_dim1;
vrmx = (d__2 = vl[i__6].r, abs(d__2));
}
/* L130: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[4] = ulpinv;
}
/* L140: */
}
/* Compute eigenvalues only, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGEEV2", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L150: */
}
/* Compute eigenvalues and right eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
&lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
&iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "ZGEEV3", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L160: */
}
/* Do Test (6) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vr_dim1;
i__6 = j + jj * lre_dim1;
if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
i__6].i) {
result[6] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* Compute eigenvalues and left eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "ZGEEV4", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L190: */
}
/* Do Test (7) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = j + jj * vl_dim1;
i__6 = j + jj * lre_dim1;
if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
i__6].i) {
result[7] = ulpinv;
}
/* L200: */
}
/* L210: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L220:
ntest = 0;
nfail = 0;
for (j = 1; j <= 7; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L230: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___48.ciunit = *nounit;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 7; ++j) {
if (result[j] >= *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L240: */
}
nerrs += nfail;
ntestt += ntest;
/* L250: */
}
L260:
;
}
/* L270: */
}
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of ZDRVEV */
} /* zdrvev_ */
/* Subroutine */ int zchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
doublecomplex *x, doublecomplex *xact, doublecomplex *work,
doublereal *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
doublereal rcond;
integer nimat;
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
doublereal rcondc;
doublereal cndnum;
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKPO tests ZPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX+2*NSMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrpo_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
zlaipd_(&n, &a[1], &i__3, &c__0);
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRF", (ftnlen)32, (ftnlen)6);
zpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from ZPOTRF. */
if (info != izero) {
alaerh_(path, "ZPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
zpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRI", (ftnlen)32, (ftnlen)6);
zpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from ZPOTRI. */
if (info != 0) {
alaerh_(path, "ZPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
zpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRS", (ftnlen)32, (ftnlen)
6);
zpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from ZPOTRS. */
if (info != 0) {
alaerh_(path, "ZPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
zpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZPORFS", (ftnlen)32, (ftnlen)
6);
zporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1],
&info);
/* Check error code from ZPORFS. */
if (info != 0) {
alaerh_(path, "ZPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "ZPOCON", (ftnlen)32, (ftnlen)6);
zpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &rwork[1], &info);
/* Check error code from ZPOCON. */
if (info != 0) {
alaerh_(path, "ZPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKPO */
} /* zchkpo_ */
/* Subroutine */ int zchkhb_(integer *nsizes, integer *nn, integer *nwdths,
integer *kk, integer *ntypes, logical *dotype, integer *iseed,
doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda,
doublereal *sd, doublereal *se, doublecomplex *u, integer *ldu,
doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
result, integer *info)
{
/* Initialized data */
static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHB: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian Banded Tridi"
"agonal Reduction Routines\002)";
static char fmt_9997[] = "(\002 Matrix types (see DCHK23 for details):"
" \002)";
static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 5=Diagonal: clustered ent"
"ries.\002,/\002 2=Identity matrix. \002,\002"
" 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
"y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
"\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
"/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
" evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
"nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
"/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
" with large random entries.\002,/\002 11=Large, evenly spaced ei"
"genvals. \002,\002 15=Matrix with small random entries.\002)";
static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
"is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
"O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
" \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
"PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
" \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
"\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
"=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k, n, jc, jr;
doublereal ulp, cond;
integer jcol, kmax, nmax;
doublereal unfl, ovfl, temp1;
logical badnn;
integer imode, iinfo;
extern /* Subroutine */ int zhbt21_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *);
doublereal aninv, anorm;
integer nmats, jsize, nerrs, itype, jtype, ntest;
logical badnnb;
extern doublereal dlamch_(char *);
integer idumma[1];
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*);
integer jwidth;
extern /* Subroutine */ int zhbtrd_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlaset_(char *,
integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *), zlatmr_(integer *, integer *,
char *, integer *, char *, doublecomplex *, integer *,
doublereal *, doublecomplex *, char *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
char *, integer *, integer *, integer *, doublereal *,
doublereal *, char *, doublecomplex *, integer *, integer *,
integer *);
doublereal rtunfl, rtovfl, ulpinv;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHB tests the reduction of a Hermitian band matrix to tridiagonal */
/* from, used with the Hermitian eigenvalue problem. */
/* ZHBTRD factors a Hermitian band matrix A as U S U* , where * means */
/* conjugate transpose, S is symmetric tridiagonal, and U is unitary. */
/* ZHBTRD can use either just the lower or just the upper triangle */
/* of A; ZCHKHB checks both cases. */
/* When ZCHKHB is called, a number of matrix "sizes" ("n's"), a number */
/* of bandwidths ("k's"), and a number of matrix "types" are */
/* specified. For each size ("n"), each bandwidth ("k") less than or */
/* equal to "n", and each type of matrix, one matrix will be generated */
/* and used to test the hermitian banded reduction routine. For each */
/* matrix, a number of tests will be performed: */
/* (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
/* UPLO='U' */
/* (2) | I - UU* | / ( n ulp ) */
/* (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
/* UPLO='L' */
/* (4) | I - UU* | / ( n ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U* D U, where U is unitary and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U* D U, where U is unitary and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U* D U, where U is unitary and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Hermitian matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZCHKHB does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NWDTHS (input) INTEGER */
/* The number of bandwidths to use. If it is zero, */
/* ZCHKHB does nothing. It must be at least zero. */
/* KK (input) INTEGER array, dimension (NWDTHS) */
/* An array containing the bandwidths to be used for the band */
/* matrices. The values must be at least zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKHB */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKHB to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) DOUBLE PRECISION array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 2 (not 1!) */
/* and at least max( KK )+1. */
/* SD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the diagonal of the tridiagonal matrix computed */
/* by ZHBTRD. */
/* SE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the tridiagonal matrix */
/* computed by ZHBTRD. */
/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
/* Used to hold the unitary matrix computed by ZHBTRD. */
/* LDU (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max( LDA+1, max(NN)+1 )*max(NN). */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* NTESTT The total number of tests performed so far. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far. */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--kk;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
badnnb = FALSE_;
kmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kmax, i__3 = kk[j];
kmax = max(i__2,i__3);
if (kk[j] < 0) {
badnnb = TRUE_;
}
/* L20: */
}
/* Computing MIN */
i__1 = nmax - 1;
kmax = min(i__1,kmax);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*nwdths < 0) {
*info = -3;
} else if (badnnb) {
*info = -4;
} else if (*ntypes < 0) {
*info = -5;
} else if (*lda < kmax + 1) {
*info = -11;
} else if (*ldu < nmax) {
*info = -15;
} else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
aninv = 1. / (doublereal) max(1,n);
i__2 = *nwdths;
for (jwidth = 1; jwidth <= i__2; ++jwidth) {
k = kk[jwidth];
if (k > n) {
goto L180;
}
/* Computing MAX */
/* Computing MIN */
i__5 = n - 1;
i__3 = 0, i__4 = min(i__5,k);
k = max(i__3,i__4);
if (*nsizes != 1) {
mtypes = min(15,*ntypes);
} else {
mtypes = min(16,*ntypes);
}
i__3 = mtypes;
for (jtype = 1; jtype <= i__3; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
++nmats;
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L30: */
}
/* Compute "A". */
/* Store as "Upper"; later, we will copy to other format. */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random (none) */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 positive definite */
/* =10 diagonally dominant tridiagonal */
if (mtypes > 15) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
if (jtype <= 15) {
cond = ulpinv;
} else {
cond = ulpinv * aninv / 10.;
}
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__4 = n;
for (jcol = 1; jcol <= i__4; ++jcol) {
i__5 = k + 1 + jcol * a_dim1;
a[i__5].r = anorm, a[i__5].i = 0.;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
a_dim1], lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &c__0, &c__0, &c_b42, &anorm, "Q", &a[k +
1 + a_dim1], lda, idumma, &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &k, &k, &c_b42, &anorm, "Q", &a[a_offset],
lda, idumma, &iinfo);
} else if (itype == 9) {
/* Positive definite, eigenvalues specified. */
zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[n + 1], &iinfo);
} else if (itype == 10) {
/* Positive definite tridiagonal, eigenvalues specified. */
if (n > 1) {
k = max(1,k);
}
zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
lda, &work[1], &iinfo);
i__4 = n;
for (i__ = 2; i__ <= i__4; ++i__) {
i__5 = k + 1 + (i__ - 1) * a_dim1;
i__6 = k + 1 + i__ * a_dim1;
z__1.r = a[i__5].r * a[i__6].r - a[i__5].i * a[i__6]
.i, z__1.i = a[i__5].r * a[i__6].i + a[i__5]
.i * a[i__6].r;
temp1 = z_abs(&a[k + i__ * a_dim1]) / sqrt(z_abs(&
z__1));
if (temp1 > .5) {
i__5 = k + i__ * a_dim1;
i__6 = k + 1 + (i__ - 1) * a_dim1;
i__7 = k + 1 + i__ * a_dim1;
z__1.r = a[i__6].r * a[i__7].r - a[i__6].i * a[
i__7].i, z__1.i = a[i__6].r * a[i__7].i +
a[i__6].i * a[i__7].r;
d__1 = sqrt(z_abs(&z__1)) * .5;
a[i__5].r = d__1, a[i__5].i = 0.;
}
/* L90: */
}
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call ZHBTRD to compute S and U from upper triangle. */
i__4 = k + 1;
zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 1;
zhbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___37.ciunit = *nounit;
s_wsfe(&io___37);
do_fio(&c__1, "ZHBTRD(U)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[1] = ulpinv;
goto L150;
}
}
/* Do tests 1 and 2 */
zhbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[1]);
/* Convert A from Upper-Triangle-Only storage to */
/* Lower-Triangle-Only storage. */
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
/* Computing MIN */
i__6 = k, i__7 = n - jc;
i__5 = min(i__6,i__7);
for (jr = 0; jr <= i__5; ++jr) {
i__6 = jr + 1 + jc * a_dim1;
d_cnjg(&z__1, &a[k + 1 - jr + (jc + jr) * a_dim1]);
a[i__6].r = z__1.r, a[i__6].i = z__1.i;
/* L110: */
}
/* L120: */
}
i__4 = n;
for (jc = n + 1 - k; jc <= i__4; ++jc) {
/* Computing MIN */
i__5 = k, i__6 = n - jc;
i__7 = k;
for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
i__5 = jr + 1 + jc * a_dim1;
a[i__5].r = 0., a[i__5].i = 0.;
/* L130: */
}
/* L140: */
}
/* Call ZHBTRD to compute S and U from lower triangle */
i__4 = k + 1;
zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 3;
zhbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHBTRD(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L150;
}
}
ntest = 4;
/* Do tests 3 and 4 */
zhbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[3]);
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
ntestt += ntest;
/* Print out tests which fail. */
i__4 = ntest;
for (jr = 1; jr <= i__4; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHB", (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Hermitian", (ftnlen)9);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 4; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L160: */
}
L170:
;
}
L180:
;
}
/* L190: */
}
/* Summary */
dlasum_("ZHB", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHB */
} /* zchkhb_ */
/* Subroutine */ int zdrvsp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, 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 facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio =\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode, imat, info;
static char path[3], dist[1], uplo[1], type__[1];
static integer nrun, i__, j, k, n, ifact, nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static integer nbmin;
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static integer iuplo, izero, i1, i2, k1, nerrs;
extern /* Subroutine */ int zspt01_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zppt05_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zspt02_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *);
static char xtype[1];
extern /* Subroutine */ int zspsv_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
integer *, integer *, doublereal *, integer *, doublereal *,
char *), aladhd_(integer *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
static char packit[1];
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum, ainvnm;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *), zlatsp_(char
*, integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zsptrf_(char *, integer *, doublecomplex *,
integer *, integer *), zsptri_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zerrvx_(char *, integer *), zspsvx_(char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, doublecomplex *,
doublereal *, integer *);
static integer lda, npp;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZDRVSP tests the driver routines ZSPSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX*16 array, dimension
(NMAX*(NMAX+1)/2)
AFAC (workspace) COMPLEX*16 array, dimension
(NMAX*(NMAX+1)/2)
AINV (workspace) COMPLEX*16 array, dimension
(NMAX*(NMAX+1)/2)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(2,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'R';
}
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, packit, &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) * izero / 2;
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 += i__;
/* 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 = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
if (iuplo == 1) {
/* Set the first IZERO rows and columns 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 += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns 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 = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* Use a special block diagonal matrix to test alternate
code for the 2-by-2 blocks. */
zlatsp_(uplo, &n, &a[1], iseed);
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with
the value returned by ZSPSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = zlansp_("1", uplo, &n, &a[1], &rwork[1]);
/* Factor the matrix A. */
zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
zsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Compute inv(A) and take its norm. */
zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
zsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
info);
ainvnm = zlansp_("1", uplo, &n, &ainv[1], &rwork[1]);
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test ZSPSV --- */
if (ifact == 2) {
zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using ZSPSV. */
s_copy(srnamc_1.srnamt, "ZSPSV ", (ftnlen)6, (ftnlen)
6);
zspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
lda, &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from ZSPSV . */
if (info != k) {
alaerh_(path, "ZSPSV ", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L120;
} else if (info != 0) {
goto L120;
}
/* Reconstruct matrix from factors and compute
residual. */
zspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
, &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "ZSPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
L120:
;
}
/* --- Test ZSPSVX --- */
if (ifact == 2 && npp > 0) {
zlaset_("Full", &npp, &c__1, &c_b61, &c_b61, &afac[1],
&npp);
}
zlaset_("Full", &n, nrhs, &c_b61, &c_b61, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using ZSPSVX. */
s_copy(srnamc_1.srnamt, "ZSPSVX", (ftnlen)6, (ftnlen)6);
zspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
&b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &rwork[(*nrhs << 1) +
1], &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from ZSPSVX. */
if (info != k) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "ZSPSVX", &info, &k, ch__1, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L150;
}
if (info == 0) {
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
zspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[(*nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
zppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from ZSPSVX with the computed value
in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "ZSPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L140: */
}
nrun = nrun + 7 - k1;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVSP */
} /* zdrvsp_ */
/* Subroutine */ int zlattb_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, integer *kd, doublecomplex *ab,
integer *ldab, doublecomplex *b, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double pow_dd(doublereal *, doublereal *), z_abs(doublecomplex *);
/* Local variables */
static doublereal sfac;
static integer ioff, mode, lenj;
static char path[3], dist[1];
static doublereal unfl, rexp;
static char type__[1];
static doublereal texp;
static doublecomplex star1, plus1, plus2;
static integer i__, j;
static doublereal bscal;
extern logical lsame_(char *, char *);
static doublereal tscal, anorm, bnorm, tleft;
static logical upper;
static doublereal tnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlatb4_(char *, integer *,
integer *, integer *, char *, integer *, integer *, doublereal *,
integer *, doublereal *, char *),
dlabad_(doublereal *, doublereal *);
static integer kl;
extern doublereal dlamch_(char *);
static integer ku, iy;
extern doublereal dlarnd_(integer *, integer *);
static char packit[1];
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal bignum, cndnum;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
static integer jcount;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublereal ulp;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_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
=======
ZLATTB generates a triangular test matrix in 2-dimensional storage.
IMAT and UPLO uniquely specify the properties of the test matrix,
which is returned in the array A.
Arguments
=========
IMAT (input) INTEGER
An integer key describing which matrix to generate for this
path.
UPLO (input) CHARACTER*1
Specifies whether the matrix A will be upper or lower
triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies whether the matrix or its transpose will be used.
= 'N': No transpose
= 'T': Transpose
= 'C': Conjugate transpose (= transpose)
DIAG (output) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
ISEED (input/output) INTEGER array, dimension (4)
The seed vector for the random number generator (used in
ZLATMS). Modified on exit.
N (input) INTEGER
The order of the matrix to be generated.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the banded
triangular matrix A. KD >= 0.
AB (output) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular banded matrix A, stored in the
first KD+1 rows of AB. Let j be a column of A, 1<=j<=n.
If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
B (workspace) COMPLEX*16 array, dimension (N)
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Parameter adjustments */
--iseed;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--b;
--work;
--rwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
smlnum = unfl;
bignum = (1. - ulp) / smlnum;
dlabad_(&smlnum, &bignum);
if (*imat >= 6 && *imat <= 9 || *imat == 17) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call ZLATB4 to set parameters for CLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
ku = *kd;
/* Computing MAX */
i__1 = 0, i__2 = *kd - *n + 1;
ioff = max(i__1,i__2) + 1;
kl = 0;
*(unsigned char *)packit = 'Q';
} else {
i__1 = -(*imat);
zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
kl = *kd;
ioff = 1;
ku = 0;
*(unsigned char *)packit = 'B';
}
/* IMAT <= 5: Non-unit triangular matrix */
if (*imat <= 5) {
zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, packit, &ab_ref(ioff, 1), ldab, &work[1],
info);
/* IMAT > 5: Unit triangular matrix
The diagonal is deliberately set to something other than 1.
IMAT = 6: Matrix is the identity */
} else if (*imat == 6) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
i__4 = *kd;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = ab_subscr(i__, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
/* L10: */
}
i__4 = ab_subscr(*kd + 1, j);
ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__4 = ab_subscr(1, j);
ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
i__4 = min(i__2,i__3);
for (i__ = 2; i__ <= i__4; ++i__) {
i__2 = ab_subscr(i__, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
/* L30: */
}
/* L40: */
}
}
/* IMAT > 6: Non-trivial unit triangular matrix
A unit triangular matrix T with condition CNDNUM is formed.
In this version, T only has bandwidth 2, the rest of it is zero. */
} else if (*imat <= 9) {
tnorm = sqrt(cndnum);
/* Initialize AB to zero. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__4 = 1, i__2 = *kd + 2 - j;
i__3 = *kd;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
i__4 = ab_subscr(i__, j);
ab[i__4].r = 0., ab[i__4].i = 0.;
/* L50: */
}
i__3 = ab_subscr(*kd + 1, j);
d__1 = (doublereal) j;
ab[i__3].r = d__1, ab[i__3].i = 0.;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *kd + 1, i__2 = *n - j + 1;
i__3 = min(i__4,i__2);
for (i__ = 2; i__ <= i__3; ++i__) {
i__4 = ab_subscr(i__, j);
ab[i__4].r = 0., ab[i__4].i = 0.;
/* L70: */
}
i__3 = ab_subscr(1, j);
d__1 = (doublereal) j;
ab[i__3].r = d__1, ab[i__3].i = 0.;
/* L80: */
}
}
/* Special case: T is tridiagonal. Set every other offdiagonal
so that the matrix has norm TNORM+1. */
if (*kd == 1) {
if (upper) {
i__1 = ab_subscr(1, 2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
lenj = (*n - 3) / 2;
zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
i__1 = lenj;
for (j = 1; j <= i__1; ++j) {
i__3 = ab_subscr(1, j + 1 << 1);
i__4 = j;
z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
.i;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L90: */
}
} else {
i__1 = ab_subscr(2, 1);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
lenj = (*n - 3) / 2;
zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
i__1 = lenj;
for (j = 1; j <= i__1; ++j) {
i__3 = ab_subscr(2, (j << 1) + 1);
i__4 = j;
z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
.i;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L100: */
}
}
} else if (*kd > 1) {
/* Form a unit triangular matrix T with condition CNDNUM. T is
given by
| 1 + * |
| 1 + |
T = | 1 + * |
| 1 + |
| 1 + * |
| 1 + |
| . . . |
Each element marked with a '*' is formed by taking the product
of the adjacent elements marked with '+'. The '*'s can be
chosen freely, and the '+'s are chosen so that the inverse of
T will have elements of the same magnitude as T.
The two offdiagonals of T are stored in WORK. */
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
sfac = sqrt(tnorm);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
plus1.r = z__1.r, plus1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
z_div(&z__1, &star1, &plus1);
plus2.r = z__1.r, plus2.i = z__1.i;
i__3 = j;
work[i__3].r = plus1.r, work[i__3].i = plus1.i;
i__3 = *n + j;
work[i__3].r = star1.r, work[i__3].i = star1.i;
if (j + 1 <= *n) {
i__3 = j + 1;
work[i__3].r = plus2.r, work[i__3].i = plus2.i;
i__3 = *n + j + 1;
work[i__3].r = 0., work[i__3].i = 0.;
z_div(&z__1, &star1, &plus2);
plus1.r = z__1.r, plus1.i = z__1.i;
/* Generate a new *-value with norm between sqrt(TNORM)
and TNORM. */
rexp = dlarnd_(&c__2, &iseed[1]);
if (rexp < 0.) {
d__2 = 1. - rexp;
d__1 = -pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
} else {
d__2 = rexp + 1.;
d__1 = pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
}
}
/* L110: */
}
/* Copy the tridiagonal T to AB. */
if (upper) {
i__1 = *n - 1;
zcopy_(&i__1, &work[1], &c__1, &ab_ref(*kd, 2), ldab);
i__1 = *n - 2;
zcopy_(&i__1, &work[*n + 1], &c__1, &ab_ref(*kd - 1, 3), ldab)
;
} else {
i__1 = *n - 1;
zcopy_(&i__1, &work[1], &c__1, &ab_ref(2, 1), ldab);
i__1 = *n - 2;
zcopy_(&i__1, &work[*n + 1], &c__1, &ab_ref(3, 1), ldab);
}
}
/* IMAT > 9: Pathological test cases. These triangular matrices
are badly scaled or badly conditioned, so when used in solving a
triangular system they may cause overflow in the solution vector. */
} else if (*imat == 10) {
/* Type 10: Generate a triangular matrix with elements between
-1 and 1. Give the diagonal norm 2 to make it well-conditioned.
Make the right hand side large so that it requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 1 - lenj, j));
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L120: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L130: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 11) {
/* Type 11: Make the first diagonal element in the solve small to
cause immediate overflow when dividing by T(j,j).
In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
tscal = 1. / (doublereal) (*kd + 1);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj,
j));
zdscal_(&lenj, &tscal, &ab_ref(*kd + 2 - lenj, j), &c__1);
}
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L140: */
}
i__1 = ab_subscr(*kd + 1, *n);
i__3 = ab_subscr(*kd + 1, *n);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
zdscal_(&lenj, &tscal, &ab_ref(2, j), &c__1);
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L150: */
}
i__1 = ab_subscr(1, 1);
i__3 = ab_subscr(1, 1);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to
cause immediate overflow when dividing by T(j,j).
In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj,
j));
}
i__3 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L160: */
}
i__1 = ab_subscr(*kd + 1, *n);
i__3 = ab_subscr(*kd + 1, *n);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n - j;
lenj = min(i__3,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__3 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
/* L170: */
}
i__1 = ab_subscr(1, 1);
i__3 = ab_subscr(1, 1);
z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
} else if (*imat == 13) {
/* Type 13: T is diagonal with small numbers on the diagonal to
make the growth factor underflow, but a small right hand side
chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
for (j = *n; j >= 1; --j) {
/* Computing MAX */
i__1 = 1, i__3 = *kd + 1 - (j - 1);
i__4 = *kd;
for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L180: */
}
if (jcount <= 2) {
i__4 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
} else {
i__4 = ab_subscr(*kd + 1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L190: */
}
} else {
jcount = 1;
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__3 = *n - j + 1, i__2 = *kd + 1;
i__1 = min(i__3,i__2);
for (i__ = 2; i__ <= i__1; ++i__) {
i__3 = ab_subscr(i__, j);
ab[i__3].r = 0., ab[i__3].i = 0.;
/* L200: */
}
if (jcount <= 2) {
i__1 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
} else {
i__1 = ab_subscr(1, j);
zlarnd_(&z__1, &c__5, &iseed[1]);
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L210: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1].r = 0., b[1].i = 0.;
for (i__ = *n; i__ >= 2; i__ += -2) {
i__4 = i__;
b[i__4].r = 0., b[i__4].i = 0.;
i__4 = i__ - 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
/* L220: */
}
} else {
i__4 = *n;
b[i__4].r = 0., b[i__4].i = 0.;
i__4 = *n - 1;
for (i__ = 1; i__ <= i__4; i__ += 2) {
i__1 = i__;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = i__ + 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L230: */
}
}
} else if (*imat == 14) {
/* Type 14: Make the diagonal elements small to cause gradual
overflow when dividing by T(j,j). To control the amount of
scaling needed, the matrix is bidiagonal. */
texp = 1. / (doublereal) (*kd + 1);
tscal = pow_dd(&smlnum, &texp);
zlarnv_(&c__4, &iseed[1], n, &b[1]);
if (upper) {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__1 = 1, i__3 = *kd + 2 - j;
i__2 = *kd;
for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L240: */
}
if (j > 1 && *kd > 0) {
i__2 = ab_subscr(*kd, j);
ab[i__2].r = -1., ab[i__2].i = -1.;
}
i__2 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
/* L250: */
}
i__4 = *n;
b[i__4].r = 1., b[i__4].i = 1.;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__1 = *n - j + 1, i__3 = *kd + 1;
i__2 = min(i__1,i__3);
for (i__ = 3; i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L260: */
}
if (j < *n && *kd > 0) {
i__2 = ab_subscr(2, j);
ab[i__2].r = -1., ab[i__2].i = -1.;
}
i__2 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
/* L270: */
}
b[1].r = 1., b[1].i = 1.;
}
} else if (*imat == 15) {
/* Type 15: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__2 = j, i__1 = *kd + 1;
lenj = min(i__2,i__1);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj, j));
if (j != iy) {
i__2 = ab_subscr(*kd + 1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
} else {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
}
/* L280: */
}
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MIN */
i__2 = *n - j + 1, i__1 = *kd + 1;
lenj = min(i__2,i__1);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(1, j));
if (j != iy) {
i__2 = ab_subscr(1, j);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
} else {
i__2 = ab_subscr(1, j);
ab[i__2].r = 0., ab[i__2].i = 0.;
}
/* L290: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b91, &b[1], &c__1);
} else if (*imat == 16) {
/* Type 16: Make the offdiagonal elements large to cause overflow
when adding a column of T. In the non-transposed case, the
matrix is constructed to cause overflow when adding a column in
every other step. */
tscal = unfl / ulp;
tscal = (1. - ulp) / tscal;
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
i__2 = *kd + 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = ab_subscr(i__, j);
ab[i__1].r = 0., ab[i__1].i = 0.;
/* L300: */
}
/* L310: */
}
texp = 1.;
if (*kd > 0) {
if (upper) {
i__4 = -(*kd);
for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
i__2 = max(i__1,i__3);
for (i__ = j; i__ >= i__2; i__ += -2) {
i__1 = ab_subscr(j - i__ + 1, i__);
d__1 = -tscal / (doublereal) (*kd + 2);
ab[i__1].r = d__1, ab[i__1].i = 0.;
i__1 = ab_subscr(*kd + 1, i__);
ab[i__1].r = 1., ab[i__1].i = 0.;
i__1 = i__;
d__1 = texp * (1. - ulp);
b[i__1].r = d__1, b[i__1].i = 0.;
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
if (i__ > max(i__1,i__3)) {
i__1 = ab_subscr(j - i__ + 2, i__ - 1);
d__1 = -(tscal / (doublereal) (*kd + 2)) / (
doublereal) (*kd + 3);
ab[i__1].r = d__1, ab[i__1].i = 0.;
i__1 = ab_subscr(*kd + 1, i__ - 1);
ab[i__1].r = 1., ab[i__1].i = 0.;
i__1 = i__ - 1;
d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ *kd);
b[i__1].r = d__1, b[i__1].i = 0.;
}
texp *= 2.;
/* L320: */
}
/* Computing MAX */
i__1 = 1, i__3 = j - *kd + 1;
i__2 = max(i__1,i__3);
d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
tscal;
b[i__2].r = d__1, b[i__2].i = 0.;
/* L330: */
}
} else {
i__4 = *n;
i__2 = *kd;
for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
texp = 1.;
/* Computing MIN */
i__1 = *kd + 1, i__3 = *n - j + 1;
lenj = min(i__1,i__3);
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
i__1 = min(i__3,i__5);
for (i__ = j; i__ <= i__1; i__ += 2) {
i__3 = ab_subscr(lenj - (i__ - j), j);
d__1 = -tscal / (doublereal) (*kd + 2);
ab[i__3].r = d__1, ab[i__3].i = 0.;
i__3 = ab_subscr(1, j);
ab[i__3].r = 1., ab[i__3].i = 0.;
i__3 = j;
d__1 = texp * (1. - ulp);
b[i__3].r = d__1, b[i__3].i = 0.;
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
if (i__ < min(i__3,i__5)) {
i__3 = ab_subscr(lenj - (i__ - j + 1), i__ + 1);
d__1 = -(tscal / (doublereal) (*kd + 2)) / (
doublereal) (*kd + 3);
ab[i__3].r = d__1, ab[i__3].i = 0.;
i__3 = ab_subscr(1, i__ + 1);
ab[i__3].r = 1., ab[i__3].i = 0.;
i__3 = i__ + 1;
d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ *kd);
b[i__3].r = d__1, b[i__3].i = 0.;
}
texp *= 2.;
/* L340: */
}
/* Computing MIN */
i__3 = *n, i__5 = j + *kd - 1;
i__1 = min(i__3,i__5);
d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
tscal;
b[i__1].r = d__1, b[i__1].i = 0.;
/* L350: */
}
}
}
} else if (*imat == 17) {
/* Type 17: Generate a unit triangular matrix with elements
between -1 and 1, and make the right hand side large so that it
requires scaling. */
if (upper) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = j - 1;
lenj = min(i__4,*kd);
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(*kd + 1 - lenj, j));
i__4 = ab_subscr(*kd + 1, j);
d__1 = (doublereal) j;
ab[i__4].r = d__1, ab[i__4].i = 0.;
/* L360: */
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - j;
lenj = min(i__4,*kd);
if (lenj > 0) {
zlarnv_(&c__4, &iseed[1], &lenj, &ab_ref(2, j));
}
i__4 = ab_subscr(1, j);
d__1 = (doublereal) j;
ab[i__4].r = d__1, ab[i__4].i = 0.;
/* L370: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 18) {
/* Type 18: Generate a triangular matrix with elements between
BIGNUM/(KD+1) and BIGNUM so that at least one of the column
norms will exceed BIGNUM.
1/3/91: ZLATBS no longer can handle this case */
tleft = bignum / (doublereal) (*kd + 1);
tscal = bignum * ((doublereal) (*kd + 1) / (doublereal) (*kd + 2));
if (upper) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = j, i__1 = *kd + 1;
lenj = min(i__4,i__1);
zlarnv_(&c__5, &iseed[1], &lenj, &ab_ref(*kd + 2 - lenj, j));
dlarnv_(&c__1, &iseed[1], &lenj, &rwork[*kd + 2 - lenj]);
i__4 = *kd + 1;
for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
i__3 = ab_subscr(i__, j);
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
/* L380: */
}
/* L390: */
}
} else {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
zlarnv_(&c__5, &iseed[1], &lenj, &ab_ref(1, j));
dlarnv_(&c__1, &iseed[1], &lenj, &rwork[1]);
i__4 = lenj;
for (i__ = 1; i__ <= i__4; ++i__) {
i__1 = ab_subscr(i__, j);
i__3 = ab_subscr(i__, j);
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
/* L400: */
}
/* L410: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b91, &b[1], &c__1);
}
/* Flip the matrix if the transpose will be used. */
if (! lsame_(trans, "N")) {
if (upper) {
i__2 = *n / 2;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
i__4 = *ldab - 1;
zswap_(&lenj, &ab_ref(*kd + 1, j), &i__4, &ab_ref(*kd + 2 -
lenj, *n - j + 1), &c_n1);
/* L420: */
}
} else {
i__2 = *n / 2;
for (j = 1; j <= i__2; ++j) {
/* Computing MIN */
i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
lenj = min(i__4,i__1);
i__4 = -(*ldab) + 1;
zswap_(&lenj, &ab_ref(1, j), &c__1, &ab_ref(lenj, *n - j + 2
- lenj), &i__4);
/* L430: */
}
}
}
return 0;
/* End of ZLATTB */
} /* zlattb_ */
/* Subroutine */ int zdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__,
doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl,
doublecomplex *vr, integer *ldvr, doublecomplex *lre, integer *ldlre,
doublereal *rcondv, doublereal *rcndv1, doublereal *rcdvin,
doublereal *rconde, doublereal *rcnde1, doublereal *rcdein,
doublereal *scale, doublereal *scale1, doublereal *result,
doublecomplex *work, integer *nwork, doublereal *rwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 ZDRVVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
"see ZDRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__, j, n;
doublereal wi, wr;
integer iwk;
doublereal ulp;
integer ibal;
doublereal cond;
integer jcol;
char path[3];
integer nmax;
doublereal unfl, ovfl;
integer isrt;
logical badnn;
integer nfail, imode, iinfo;
doublereal conds, anorm;
extern /* Subroutine */ int zget23_(logical *, integer *, char *, integer
*, doublereal *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublecomplex *,
integer *, doublereal *, integer *);
integer jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
char balanc[1];
extern doublereal dlamch_(char *);
integer idumma[1];
integer ioldsd[4];
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*), zlatme_(integer *, char *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *, char *,
char *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
integer ntestf;
extern /* Subroutine */ int zlatmr_(integer *, integer *, char *, integer
*, char *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *, doublereal *, char *,
integer *, integer *, integer *, doublereal *, doublereal *, char
*, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *,
integer *, char *, integer *, char *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, char *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal ulpinv;
integer nnwork;
doublereal rtulpi;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___45 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVVX checks the nonsymmetric eigenvalue problem expert driver */
/* ZGEEVX. */
/* ZDRVVX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When ZDRVVX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified in the calling sequence. */
/* For each size ("n") and each type of matrix, one matrix will be */
/* generated and used to test the nonsymmetric eigenroutines. For */
/* each matrix, 9 tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
/* and RCONDE are also computed, and W(partial) denotes the */
/* eigenvalues computed when only some of VR, VL, RCONDV, and */
/* RCONDE are computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
/* and RCONDE are computed, and VR(partial) denotes the result */
/* when only some of VL and RCONDV are computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
/* and RCONDE are computed, and VL(partial) denotes the result */
/* when only some of VR and RCONDV are computed. */
/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
/* SCALE, ILO, IHI, ABNRM (partial) */
/* 1/ulp otherwise */
/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
/* (partial) is when some are not computed. */
/* (9) RCONDV(full) = RCONDV(partial) */
/* RCONDV(full) denotes the reciprocal condition numbers of the */
/* right eigenvectors computed when VR, VL and RCONDE are also */
/* computed. RCONDV(partial) denotes the reciprocal condition */
/* numbers when only some of VR, VL and RCONDE are computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalues */
/* and right eigenvectors. For these matrices, in addition to tests */
/* (1) to (9) we will compute the following two tests: */
/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right eigenvector condition number */
/* computed by ZGEEVX and RCDVIN (the precomputed true value) */
/* is supplied as input. cond(RCONDV) is the condition number of */
/* RCONDV, and takes errors in computing RCONDV into account, so */
/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
/* essentially given by norm(A)/RCONDE. */
/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal eigenvalue condition number */
/* computed by ZGEEVX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZDRVVX to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN,12)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN, 12 ). (12 is the */
/* dimension of the largest matrix on the precomputed */
/* input file.) */
/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN,12)) */
/* Another copy of the test matrix A, modified by ZGEEVX. */
/* W (workspace) COMPLEX*16 array, dimension (max(NN,12)) */
/* Contains the eigenvalues of A. */
/* W1 (workspace) COMPLEX*16 array, dimension (max(NN,12)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when ZGEEVX only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN,12)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN,12)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN,12)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN,12)) */
/* INFO (output) INTEGER */
/* If 0, then successful exit. */
/* If <0, then input paramter -INFO is incorrect. */
/* If >0, ZLATMR, CLATMS, CLATME or ZGET23 returned an error */
/* code, and INFO is its absolute value. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN or 12. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--rwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 7 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 7;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -15;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -17;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -19;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -30;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
&iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
if (n >= 4) {
zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = (n << 1) + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
zget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &
work[1], &nnwork, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___40.ciunit = *nounit;
s_wsfe(&io___40);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation. */
/* Assume input eigenvalues are sorted lexicographically (increasing */
/* by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___45.ciunit = *niunit;
i__1 = s_rsle(&io___45);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__5, &c__1, (char *)&wr, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&wi, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(doublereal))
;
e_rsle();
i__2 = i__;
z__1.r = wr, z__1.i = wi;
w1[i__2].r = z__1.r, w1[i__2].i = z__1.i;
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
zget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of ZDRVVX */
} /* zdrvvx_ */
/* Subroutine */ int ztimql_(char *line, integer *nm, integer *mval, integer *
nval, integer *nk, integer *kval, integer *nnb, integer *nbval,
integer *nxval, integer *nlda, integer *ldaval, doublereal *timmin,
doublecomplex *a, doublecomplex *tau, doublecomplex *b, doublecomplex
*work, doublereal *rwork, doublereal *reslts, integer *ldr1, integer *
ldr2, integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*3] = "ZGEQLF" "ZUNGQL" "ZUNMQL";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "C";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9996[] = "(5x,\002K = min(M,N)\002,/)";
static char fmt_9995[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', TRANS"
" = '\002,a1,\002', \002,a1,\002 =\002,i6,/)";
static char fmt_9994[] = "(\002 *** No pairs (M,N) found with M >= N: "
" \002,a6,\002 not timed\002)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda;
static char labm[1], side[1];
static integer info;
static char path[3];
static doublereal time;
static integer isub, muse[12], nuse[12], i__, k, m, n;
static char cname[6];
static integer iside;
extern doublereal dopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer itoff, itran, minmn;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer k1, i4, m1, n1;
static doublereal s1, s2;
extern /* Subroutine */ int dprtb4_(char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, ftnlen, ftnlen,
ftnlen), dprtb5_(char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *, ftnlen, ftnlen, ftnlen);
static integer ic, nb, ik, im;
extern doublereal dsecnd_(void);
static integer lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), zgeqlf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), xlaenv_(integer *,
integer *);
static doublereal untime;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical timsub[3];
extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zunmql_(char *, char *, integer *, integer
*, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lda, icl, inb, imx;
static doublereal ops;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTIMQL times the LAPACK routines to perform the QL factorization of
a COMPLEX*16 general matrix.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M and N contained in the vectors
MVAL and NVAL. The matrix sizes are used in pairs (M,N).
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NVAL (input) INTEGER array, dimension (NM)
The values of the matrix column dimension N.
NK (input) INTEGER
The number of values of K in the vector KVAL.
KVAL (input) INTEGER array, dimension (NK)
The values of the matrix dimension K, used in ZUNMQL.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) DOUBLE PRECISION
The minimum time a subroutine will be timed.
A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) COMPLEX*16 array, dimension (min(M,N))
B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
WORK (workspace) COMPLEX*16 array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
RWORK (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
RESLTS (workspace) DOUBLE PRECISION array, dimension
(LDR1,LDR2,LDR3,2*NK)
The timing results for each subroutine over the relevant
values of (M,N), (NB,NX), and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See ZLATMS for further details.
COND DOUBLE PRECISION
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX DOUBLE PRECISION
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kval;
--nbval;
--nxval;
--ldaval;
--a;
--tau;
--b;
--work;
--rwork;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__3, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L230;
}
/* Check that M <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__1, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L230;
}
/* Do for each pair of values (M,N): */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
n = nval[im];
minmn = min(m,n);
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = n * max(1,nb);
lw = max(i__4,i__5);
/* Generate a test matrix of size M by N. */
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[0]) {
/* ZGEQLF: QL factorization */
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = dsecnd_();
L10:
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L20:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_("Full", &m, &n, &a[1], &lda, &b[1], &lda);
goto L20;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("ZGEQLF", &m, &n, &c__0, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = dmflop_(&ops, &time, &info)
;
} else {
/* If ZGEQLF was not timed, generate a matrix and factor
it using ZGEQLF anyway so that the factored form of
the matrix can be used in timing the other routines. */
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
}
if (timsub[1]) {
/* ZUNGQL: Generate orthogonal matrix Q from the QL
factorization */
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = dsecnd_();
L30:
zungql_(&m, &minmn, &minmn, &b[1], &lda, &tau[1], &work[1]
, &lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L30;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L40:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("ZUNGQL", &m, &minmn, &minmn, &c__0, &nb);
reslts_ref(inb, im, ilda, 2) = dmflop_(&ops, &time, &info)
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* Print tables of results */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L90;
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L80: */
}
}
io___32.ciunit = *nout;
s_wsle(&io___32);
e_wsle();
if (isub == 2) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
}
dprtb4_("( NB, NX)", "M", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], &nval[1], nlda, &reslts_ref(1, 1, 1, isub), ldr1, ldr2,
nout, (ftnlen)11, (ftnlen)1, (ftnlen)1);
L90:
;
}
/* Time ZUNMQL separately. Here the starting matrix is M by N, and
K is the free dimension of the matrix multiplied by Q. */
if (timsub[2]) {
/* Check that K <= LDA for the input values. */
atimck_(&c__3, cname, nk, &kval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, subnam_ref(0, 3), (ftnlen)6);
e_wsfe();
goto L230;
}
/* Use only the pairs (M,N) where M >= N. */
imx = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
if (mval[im] >= nval[im]) {
++imx;
muse[imx - 1] = mval[im];
nuse[imx - 1] = nval[im];
}
/* L100: */
}
/* ZUNMQL: Multiply by Q stored as a product of elementary
transformations
Do for each pair of values (M,N): */
i__1 = imx;
for (im = 1; im <= i__1; ++im) {
m = muse[im - 1];
n = nuse[im - 1];
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Generate an M by N matrix and form its QL decomposition. */
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &a[1], &lda, &
work[1], &info);
/* Computing MAX */
i__3 = 1, i__4 = n * max(1,nb);
lw = max(i__3,i__4);
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &info);
/* Do first for SIDE = 'L', then for SIDE = 'R' */
i4 = 0;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside -
1];
/* Do for each pair of values (NB, NX) in NBVAL and
NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Do for each value of K in KVAL */
i__4 = *nk;
for (ik = 1; ik <= i__4; ++ik) {
k = kval[ik];
/* Sort out which variable is which */
if (iside == 1) {
m1 = m;
k1 = n;
n1 = k;
/* Computing MAX */
i__5 = 1, i__6 = n1 * max(1,nb);
lw = max(i__5,i__6);
} else {
n1 = m;
k1 = n;
m1 = k;
/* Computing MAX */
i__5 = 1, i__6 = m1 * max(1,nb);
lw = max(i__5,i__6);
}
/* Do first for TRANS = 'N', then for TRANS = 'T' */
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L110:
zunmql_(side, trans, &m1, &n1, &k1, &a[1], &
lda, &tau[1], &b[1], &lda, &work[1], &
lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L110;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L120:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L120;
}
time = (time - untime) / (doublereal) ic;
i__5 = iside - 1;
ops = dopla_("ZUNMQL", &m1, &n1, &k1, &i__5, &
nb);
reslts_ref(inb, im, ilda, i4 + itoff + ik) =
dmflop_(&ops, &time, &info);
itoff = *nk;
/* L130: */
}
/* L140: */
}
/* L150: */
}
i4 = *nk << 1;
/* L160: */
}
/* L170: */
}
/* L180: */
}
/* Print tables of results */
isub = 3;
i4 = 1;
if (imx >= 1) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
if (iside == 1) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)
sizeof(integer));
e_wsfe();
/* L190: */
}
}
}
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
i__1 = *nk;
for (ik = 1; ik <= i__1; ++ik) {
if (iside == 1) {
n = kval[ik];
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'M';
} else {
m = kval[ik];
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'N';
}
dprtb5_("NB", labm, "K", nnb, &nbval[1], &imx, muse,
nuse, nlda, &reslts_ref(1, 1, 1, i4), ldr1,
ldr2, nout, (ftnlen)2, (ftnlen)1, (ftnlen)1);
++i4;
/* L200: */
}
/* L210: */
}
/* L220: */
}
} else {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
}
}
L230:
return 0;
/* End of ZTIMQL */
} /* ztimql_ */
/* Subroutine */ int zckgsv_(integer *nm, integer *mval, integer *pval,
integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
doublecomplex *bf, doublecomplex *u, doublecomplex *v, doublecomplex *
q, doublereal *alpha, doublereal *beta, doublecomplex *r__, integer *
iwork, doublecomplex *work, doublereal *rwork, integer *nin, integer *
nout, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZLATMS in ZCKGSV INFO = \002,i5)";
static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2;
/* 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__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
ldv, imat;
char path[3], type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
doublereal anorm, bnorm;
integer lwork;
extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
*, integer *, char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, char *, char *),
alahdg_(integer *, char *);
doublereal cndnma, cndnmb;
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *);
logical dotype[8];
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
logical firstt;
doublereal result[7];
extern /* Subroutine */ int zgsvts_(integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCKGSV tests ZGGSVD: */
/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
/* Arguments */
/* ========= */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* PVAL (input) INTEGER array, dimension (NP) */
/* The values of the matrix row dimension P. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* U (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* V (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* Q (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* ALPHA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* BETA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* R (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NIN (input) INTEGER */
/* The unit number for input. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* > 0 : If ZLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
/* Parameter adjustments */
--rwork;
--work;
--iwork;
--r__;
--beta;
--alpha;
--q;
--v;
--u;
--bf;
--b;
--af;
--a;
--iseed;
--nval;
--pval;
--mval;
/* Function Body */
s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
ldu = *nmax;
ldv = *nmax;
ldq = *nmax;
ldr = *nmax;
lwork = *nmax * *nmax;
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
p = pval[im];
n = nval[im];
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L20;
}
/* Set up parameters with DLATB9 and generate test */
/* matrices A and B with ZLATMS. */
dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
distb);
/* Generate M by N matrix A */
zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
work[1], &iinfo);
if (iinfo != 0) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L20;
}
/* Generate P by N matrix B */
zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
work[1], &iinfo);
if (iinfo != 0) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L20;
}
nt = 6;
zgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__2 = nt;
for (i__ = 1; i__ <= i__2; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L10: */
}
nrun += nt;
L20:
;
}
/* L30: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of ZCKGSV */
} /* zckgsv_ */
/* Subroutine */ int zdrvpo_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Local variables */
integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact;
char equed[1];
integer nbmin;
doublereal rcond, roldc, scond;
integer nimat;
doublereal anorm;
logical equil;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
logical prefac;
doublereal rcondc;
logical nofact;
integer iequed;
doublereal cndnum;
doublereal ainvnm;
doublereal result[6];
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVPO tests the driver routines ZPOSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L120;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
zlaipd_(&n, &a[1], &i__3, &c__0);
/* Save a copy of the matrix A in ASAV. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L90;
}
rcondc = 0.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by ZPOSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
zlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
zpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
zlaqhe_(uplo, &n, &afac[1], &lda, &s[1], &
scond, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in ZGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = zlanhe_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
zpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
zpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlanhe_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
zlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test ZPOSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "ZPOSV ", (ftnlen)32, (
ftnlen)6);
zposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from ZPOSV . */
if (info != izero) {
alaerh_(path, "ZPOSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
&work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "ZPOSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test ZPOSVX --- */
if (! prefac) {
zlaset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
zlaset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
zlaqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using ZPOSVX. */
s_copy(srnamc_1.srnamt, "ZPOSVX", (ftnlen)32, (ftnlen)
6);
zposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
&rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from ZPOSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "ZPOSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
zpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
zpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from ZPOSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "ZPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "ZPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
;
}
/* L100: */
}
L110:
;
}
L120:
;
}
/* L130: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPO */
} /* zdrvpo_ */
/* Subroutine */ int ztimtd_(char *line, integer *nm, integer *mval, integer *
nn, integer *nval, integer *nnb, integer *nbval, integer *nxval,
integer *nlda, integer *ldaval, doublereal *timmin, doublecomplex *a,
doublecomplex *b, doublereal *d__, doublecomplex *tau, doublecomplex *
work, doublereal *reslts, integer *ldr1, integer *ldr2, integer *ldr3,
integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*3] = "ZHETRD" "ZUNGTR" "ZUNMTR";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "C";
static char uplos[1*2] = "U" "L";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"*** \002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9996[] = "(/5x,a6,\002 with UPLO = '\002,a1,\002'\002,/)";
static char fmt_9995[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', UPLO "
"= '\002,a1,\002', TRANS = '\002,a1,\002', \002,a1,\002 =\002,i6,"
"/)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ilda;
static char side[1];
static integer info;
static char path[3];
static doublereal time;
static integer isub;
static char uplo[1];
static integer i__, m, n;
static char cname[6];
static integer iside;
extern doublereal dopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer itoff, itran;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer iuplo, i3, i4, m1, n1;
static doublereal s1, s2;
extern /* Subroutine */ int dprtb3_(char *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *, ftnlen, ftnlen);
static integer ic, nb, im, in;
extern doublereal dsecnd_(void);
static integer lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), dprtbl_(
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *, ftnlen,
ftnlen), xlaenv_(integer *, integer *), zhetrd_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, integer *, integer *);
static doublereal untime;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical timsub[3];
extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zungtr_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmtr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *);
static integer lda, icl, inb;
static doublereal ops;
static char lab1[1], lab2[1];
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___11 = { 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 };
static cilist io___45 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTIMTD times the LAPACK routines ZHETRD, ZUNGTR, and CUNMTR.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix size M.
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 column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) DOUBLE PRECISION
The minimum time a subroutine will be timed.
A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
D (workspace) DOUBLE PRECISION array, dimension (2*NMAX-1)
TAU (workspace) COMPLEX*16 array, dimension (NMAX)
WORK (workspace) COMPLEX*16 array, dimension (NMAX*NBMAX)
where NBMAX is the maximum value of NB.
RESLTS (workspace) DOUBLE PRECISION array, dimension
(LDR1,LDR2,LDR3,4*NN+3)
The timing results for each subroutine over the relevant
values of M, (NB,NX), LDA, and N.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See ZLATMS for further details.
COND DOUBLE PRECISION
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX DOUBLE PRECISION
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--nbval;
--nxval;
--ldaval;
--a;
--b;
--d__;
--tau;
--work;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TD", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__3, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L220;
}
/* Check that M <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L220;
}
/* Check that K <= LDA for ZUNMTR */
if (timsub[2]) {
atimck_(&c__3, cname, nn, &nval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, subnam_ref(0, 3), (ftnlen)6);
e_wsfe();
timsub[2] = FALSE_;
}
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Do for each value of M: */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
i3 = (iuplo - 1) * *nlda + ilda;
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = m * max(1,nb);
lw = max(i__4,i__5);
/* Generate a test matrix of order M. */
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
zlatms_(&m, &m, "Uniform", iseed, "Symmetric", &d__[1], &
c__3, &c_b27, &c_b28, &m, &m, "No packing", &b[1],
&lda, &work[1], &info);
if (timsub[0]) {
/* ZHETRD: Reduction to tridiagonal form */
zlacpy_(uplo, &m, &m, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = dsecnd_();
L10:
zhetrd_(uplo, &m, &a[1], &lda, &d__[1], &d__[m + 1], &
tau[1], &work[1], &lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_(uplo, &m, &m, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L20:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_(uplo, &m, &m, &a[1], &lda, &b[1], &lda);
goto L20;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("ZHETRD", &m, &m, &c_n1, &c_n1, &nb);
reslts_ref(inb, im, i3, 1) = dmflop_(&ops, &time, &
info);
} else {
/* If ZHETRD was not timed, generate a matrix and
factor it using ZHETRD anyway so that the factored
form of the matrix can be used in timing the other
routines. */
zlacpy_(uplo, &m, &m, &b[1], &lda, &a[1], &lda);
zhetrd_(uplo, &m, &a[1], &lda, &d__[1], &d__[m + 1], &
tau[1], &work[1], &lw, &info);
}
if (timsub[1]) {
/* ZUNGTR: Generate the orthogonal matrix Q from the
reduction to Hessenberg form A = Q*H*Q' */
zlacpy_(uplo, &m, &m, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = dsecnd_();
L30:
zungtr_(uplo, &m, &b[1], &lda, &tau[1], &work[1], &lw,
&info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_(uplo, &m, &m, &a[1], &lda, &b[1], &lda);
goto L30;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L40:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_(uplo, &m, &m, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (doublereal) ic;
/* Op count for ZUNGTR: same as
ZUNGQR( N-1, N-1, N-1, ... ) */
i__4 = m - 1;
i__5 = m - 1;
i__6 = m - 1;
ops = dopla_("ZUNGQR", &i__4, &i__5, &i__6, &c_n1, &
nb);
reslts_ref(inb, im, i3, 2) = dmflop_(&ops, &time, &
info);
}
if (timsub[2]) {
/* ZUNMTR: Multiply by Q stored as a product of
elementary transformations */
i4 = 2;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[
iside - 1];
i__4 = *nn;
for (in = 1; in <= i__4; ++in) {
n = nval[in];
/* Computing MAX */
i__5 = 1, i__6 = max(1,nb) * n;
lw = max(i__5,i__6);
if (iside == 1) {
m1 = m;
n1 = n;
} else {
m1 = n;
n1 = m;
}
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char
*)&transs[itran - 1];
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
ic = 0;
s1 = dsecnd_();
L50:
zunmtr_(side, uplo, trans, &m1, &n1, &a[1]
, &lda, &tau[1], &b[1], &lda, &
work[1], &lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda,
&c__0, &c__0);
goto L50;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L60:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda,
&c__0, &c__0);
goto L60;
}
time = (time - untime) / (doublereal) ic;
/* Op count for ZUNMTR, SIDE='L': same as
ZUNMQR( 'L', TRANS, M-1, N, M-1, ...)
Op count for ZUNMTR, SIDE='R': same as
ZUNMQR( 'R', TRANS, M, N-1, N-1, ...) */
if (iside == 1) {
i__5 = m1 - 1;
i__6 = m1 - 1;
ops = dopla_("ZUNMQR", &i__5, &n1, &
i__6, &c_n1, &nb);
} else {
i__5 = n1 - 1;
i__6 = n1 - 1;
ops = dopla_("ZUNMQR", &m1, &i__5, &
i__6, &c__1, &nb);
}
reslts_ref(inb, im, i3, i4 + itoff + in) =
dmflop_(&ops, &time, &info);
itoff = *nn;
/* L70: */
}
/* L80: */
}
i4 += *nn << 1;
/* L90: */
}
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* Print tables of results for ZHETRD and ZUNGTR */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L160;
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L140: */
}
}
i3 = 1;
for (iuplo = 1; iuplo <= 2; ++iuplo) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, uplos + (iuplo - 1), (ftnlen)1);
e_wsfe();
dprtb3_("( NB, NX)", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], nlda, &reslts_ref(1, 1, i3, isub), ldr1, ldr2, nout, (
ftnlen)11, (ftnlen)1);
i3 += *nlda;
/* L150: */
}
L160:
;
}
/* Print tables of results for ZUNMTR */
isub = 3;
if (timsub[isub - 1]) {
i4 = 2;
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)lab1 = 'M';
*(unsigned char *)lab2 = 'N';
if (*nlda > 1) {
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(
integer));
e_wsfe();
/* L170: */
}
}
} else {
*(unsigned char *)lab1 = 'N';
*(unsigned char *)lab2 = 'M';
}
for (itran = 1; itran <= 2; ++itran) {
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
i3 = 1;
for (iuplo = 1; iuplo <= 2; ++iuplo) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, sides + (iside - 1), (ftnlen)1);
do_fio(&c__1, uplos + (iuplo - 1), (ftnlen)1);
do_fio(&c__1, transs + (itran - 1), (ftnlen)1);
do_fio(&c__1, lab2, (ftnlen)1);
do_fio(&c__1, (char *)&nval[in], (ftnlen)sizeof(
integer));
e_wsfe();
dprtbl_("NB", lab1, nnb, &nbval[1], nm, &mval[1],
nlda, &reslts_ref(1, 1, i3, i4 + in), ldr1,
ldr2, nout, (ftnlen)2, (ftnlen)1);
i3 += *nlda;
/* L180: */
}
/* L190: */
}
i4 += *nn;
/* L200: */
}
/* L210: */
}
}
L220:
/* Print a table of results for each timed routine. */
return 0;
/* End of ZTIMTD */
} /* ztimtd_ */
/* Subroutine */ int zcklse_(integer *nn, integer *mval, integer *pval,
integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
doublecomplex *bf, doublecomplex *x, doublecomplex *work, doublereal *
rwork, integer *nin, integer *nout, integer *info)
{
/* Format strings */
static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
"i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
"satisfy P <= N <= P+M \002,\002(this set of values will be skip"
"ped)\002)";
static char fmt_9999[] = "(\002 ZLATMS in ZCKLSE INFO = \002,i5)";
static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
char path[3], type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
doublereal anorm, bnorm;
integer lwork;
extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
*, integer *, char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, char *, char *),
alahdg_(integer *, char *);
doublereal cndnma, cndnmb;
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), zlarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *);
logical dotype[8];
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
logical firstt;
doublereal result[7];
extern /* Subroutine */ int zlsets_(integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCKLSE tests ZGGLSE - a subroutine for solving linear equality */
/* constrained least square problem (LSE). */
/* Arguments */
/* ========= */
/* NN (input) INTEGER */
/* The number of values of (M,P,N) contained in the vectors */
/* (MVAL, PVAL, NVAL). */
/* MVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix row(column) dimension M. */
/* PVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix row(column) dimension P. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column(row) dimension N. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* X (workspace) COMPLEX*16 array, dimension (5*NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NIN (input) INTEGER */
/* The unit number for input. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* > 0 : If ZLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
/* Parameter adjustments */
--rwork;
--work;
--x;
--bf;
--b;
--af;
--a;
--iseed;
--nval;
--pval;
--mval;
/* Function Body */
s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
lwork = *nmax * *nmax;
/* Check for valid input values. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (p > n || n > m + p) {
if (firstt) {
io___13.ciunit = *nout;
s_wsle(&io___13);
e_wsle();
firstt = FALSE_;
}
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L10: */
}
firstt = TRUE_;
/* Do for each value of M in MVAL. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (p > n || n > m + p) {
goto L40;
}
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L30;
}
/* Set up parameters with DLATB9 and generate test */
/* matrices A and B with ZLATMS. */
dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
distb);
zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
work[1], &iinfo);
if (iinfo != 0) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
work[1], &iinfo);
if (iinfo != 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
/* Generate the right-hand sides C and D for the LSE. */
/* Computing MAX */
i__3 = m - 1;
i__2 = max(i__3,0);
/* Computing MAX */
i__5 = n - 1;
i__4 = max(i__5,0);
i__6 = max(n,1);
i__7 = max(m,1);
zlarhs_("ZGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
&c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
i__7, &iseed[1], &iinfo);
/* Computing MAX */
i__3 = p - 1;
i__2 = max(i__3,0);
/* Computing MAX */
i__5 = n - 1;
i__4 = max(i__5,0);
i__6 = max(n,1);
i__7 = max(p,1);
zlarhs_("ZGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
<< 1) + 1], &i__7, &iseed[1], &iinfo);
nt = 2;
zlsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__2 = nt;
for (i__ = 1; i__ <= i__2; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
L30:
;
}
L40:
;
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of ZCKLSE */
} /* zcklse_ */
/* Subroutine */ int zchkgb_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublecomplex *a, integer *la, doublecomplex *afac, integer *lafac,
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 transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 *** In ZCHKGB, LA=\002,i5,\002 is too sm"
"all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
",i4,/\002 ==> Increase LA to at least \002,i5)";
static char fmt_9998[] = "(\002 *** In ZCHKGB, LAFAC=\002,i5,\002 is too"
" small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
"=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
"\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
",\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
"KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
"1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
"KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11;
/* 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, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
nkl, iku, nku, ioff, mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, doublereal *);
integer nimat, klval[4];
extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer
*, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *), zgbt05_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
integer kuval[4];
char trans[1];
integer izero, nerrs;
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
char xtype[1];
extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
integer ldafac;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
doublereal rcondc;
extern doublereal zlangb_(char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
doublereal rcondi;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublereal *, integer *);
doublereal ainvnm;
logical trfcon;
doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *,
integer *), zgbrfs_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *, doublereal *, doublereal *, doublecomplex *,
doublereal *, integer *), zgbtrf_(integer *, integer *,
integer *, integer *, doublecomplex *, integer *, integer *,
integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlarhs_(char *,
char *, char *, char *, integer *, integer *, integer *, integer *
, integer *, doublecomplex *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zgbtrs_(char *, integer *, integer *, integer *, integer
*, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *), zlatms_(integer *, integer *, char
*, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGB tests ZGBTRF, -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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* 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 column 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. */
/* A (workspace) COMPLEX*16 array, dimension (LA) */
/* LA (input) INTEGER */
/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
/* where KLMAX is the largest entry in the local array KLVAL, */
/* KUMAX is the largest entry in the local array KUVAL and */
/* NMAX is the largest entry in the input array NVAL. */
/* AFAC (workspace) COMPLEX*16 array, dimension (LAFAC) */
/* LAFAC (input) INTEGER */
/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
/* where KLMAX is the largest entry in the local array KLVAL, */
/* KUMAX is the largest entry in the local array KUVAL and */
/* NMAX is the largest entry in the input array NVAL. */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX,NMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--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, "GB", (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) {
zerrge_(path, nout);
}
infoc_1.infot = 0;
/* Initialize the first value for the lower and upper bandwidths. */
klval[0] = 0;
kuval[0] = 0;
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Set values to use for the lower bandwidth. */
klval[1] = m + (m + 1) / 4;
/* KLVAL( 2 ) = MAX( M-1, 0 ) */
klval[2] = (m * 3 - 1) / 4;
klval[3] = (m + 1) / 4;
/* Do for each value of N in NVAL */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
*(unsigned char *)xtype = 'N';
/* Set values to use for the upper bandwidth. */
kuval[1] = n + (n + 1) / 4;
/* KUVAL( 2 ) = MAX( N-1, 0 ) */
kuval[2] = (n * 3 - 1) / 4;
kuval[3] = (n + 1) / 4;
/* Set limits on the number of loop iterations. */
/* Computing MIN */
i__3 = m + 1;
nkl = min(i__3,4);
if (n == 0) {
nkl = 2;
}
/* Computing MIN */
i__3 = n + 1;
nku = min(i__3,4);
if (m == 0) {
nku = 2;
}
nimat = 8;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nkl;
for (ikl = 1; ikl <= i__3; ++ikl) {
/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
/* order makes it easier to skip redundant values for small */
/* values of M. */
kl = klval[ikl - 1];
i__4 = nku;
for (iku = 1; iku <= i__4; ++iku) {
/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
/* order makes it easier to skip redundant values for */
/* small values of N. */
ku = kuval[iku - 1];
/* Check that A and AFAC are big enough to generate this */
/* matrix. */
lda = kl + ku + 1;
ldafac = (kl << 1) + ku + 1;
if (lda * n > *la || ldafac * n > *lafac) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
if (n * (kl + ku + 1) > *la) {
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
);
i__5 = n * (kl + ku + 1);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
integer));
e_wsfe();
++nerrs;
}
if (n * ((kl << 1) + ku + 1) > *lafac) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
);
i__5 = n * ((kl << 1) + ku + 1);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
integer));
e_wsfe();
++nerrs;
}
goto L130;
}
i__5 = nimat;
for (imat = 1; imat <= i__5; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 2, 3, or 4 if the matrix size is too */
/* small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L120;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with ZLATB4 and generate a */
/* test matrix with ZLATMS. */
zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
anorm, &mode, &cndnum, dist);
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - n;
koff = max(i__6,i__7);
i__6 = koff - 1;
for (i__ = 1; i__ <= i__6; ++i__) {
i__7 = i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L20: */
}
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (
ftnlen)6);
zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &
mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
koff], &lda, &work[1], &info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &m,
&n, &kl, &ku, &c_n1, &imat, &nfail, &
nerrs, nout);
goto L120;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for */
/* type 2 by copying back the zeroed out column. */
i__6 = i2 - i1 + 1;
zcopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
}
/* For types 2, 3, and 4, zero one or more columns of */
/* the matrix to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 4) {
/* Store the column to be zeroed out in B. */
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - izero;
i1 = max(i__6,i__7);
/* Computing MIN */
i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
izero);
i2 = min(i__6,i__7);
i__6 = i2 - i1 + 1;
zcopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
c__1);
i__6 = i2;
for (i__ = i1; i__ <= i__6; ++i__) {
i__7 = ioff + i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L30: */
}
} else {
i__6 = n;
for (j = izero; j <= i__6; ++j) {
/* Computing MAX */
i__7 = 1, i__8 = ku + 2 - j;
/* Computing MIN */
i__10 = kl + ku + 1, i__11 = ku + 1 + (m
- j);
i__9 = min(i__10,i__11);
for (i__ = max(i__7,i__8); i__ <= i__9;
++i__) {
i__7 = ioff + i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L40: */
}
ioff += lda;
/* L50: */
}
}
}
/* These lines, if used in place of the calls in the */
/* loop over INB, cause the code to bomb on a Sun */
/* SPARCstation. */
/* ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
/* ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
/* Do for each blocksize in NBVAL */
i__6 = *nnb;
for (inb = 1; inb <= i__6; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the band matrix. */
if (m > 0 && n > 0) {
i__9 = kl + ku + 1;
zlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
kl + 1], &ldafac);
}
s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)6, (
ftnlen)6);
zgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
iwork[1], &info);
/* Check error code from ZGBTRF. */
if (info != izero) {
alaerh_(path, "ZGBTRF", &info, &izero, " ", &
m, &n, &kl, &ku, &nb, &imat, &nfail, &
nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1 */
/* Reconstruct matrix from factors and compute */
/* residual. */
zgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
ldafac, &iwork[1], &work[1], result);
/* Print information about the tests so far that */
/* did not pass the threshold. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ku, (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 *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Skip the remaining tests if this is not the */
/* first block size or if M .ne. N. */
if (inb > 1 || m != n) {
goto L110;
}
anormo = zlangb_("O", &n, &kl, &ku, &a[1], &lda, &
rwork[1]);
anormi = zlangb_("I", &n, &kl, &ku, &a[1], &lda, &
rwork[1]);
if (info == 0) {
/* Form the inverse of A so we can get a good */
/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
ldb = max(1,n);
zlaset_("Full", &n, &n, &c_b61, &c_b62, &work[
1], &ldb);
s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)6, (
ftnlen)6);
zgbtrs_("No transpose", &n, &kl, &ku, &n, &
afac[1], &ldafac, &iwork[1], &work[1],
&ldb, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlange_("O", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormo <= 0. || ainvnm <= 0.) {
rcondo = 1.;
} else {
rcondo = 1. / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of */
/* A. */
ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
} else {
/* Do only the condition estimate if INFO.NE.0. */
trfcon = TRUE_;
rcondo = 0.;
rcondi = 0.;
}
/* Skip the solve tests if the matrix is singular. */
if (trfcon) {
goto L90;
}
i__9 = *nns;
for (irhs = 1; irhs <= i__9; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char
*)&transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
/* + TEST 2: */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)
6, (ftnlen)6);
zlarhs_(path, xtype, " ", trans, &n, &n, &
kl, &ku, &nrhs, &a[1], &lda, &
xact[1], &ldb, &b[1], &ldb, iseed,
&info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
x[1], &ldb);
s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)
6, (ftnlen)6);
zgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
1], &ldafac, &iwork[1], &x[1], &
ldb, &info);
/* Check error code from ZGBTRS. */
if (info != 0) {
alaerh_(path, "ZGBTRS", &info, &c__0,
trans, &n, &n, &kl, &ku, &
c_n1, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
work[1], &ldb);
zgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
a[1], &lda, &x[1], &ldb, &work[1],
&ldb, &result[1]);
/* + TEST 3: */
/* Check solution from generated exact */
/* solution. */
zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
&ldb, &rcondc, &result[2]);
/* + TESTS 4, 5, 6: */
/* Use iterative refinement to improve the */
/* solution. */
s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)
6, (ftnlen)6);
zgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
&lda, &afac[1], &ldafac, &iwork[
1], &b[1], &ldb, &x[1], &ldb, &
rwork[1], &rwork[nrhs + 1], &work[
1], &rwork[(nrhs << 1) + 1], &
info);
/* Check error code from ZGBRFS. */
if (info != 0) {
alaerh_(path, "ZGBRFS", &info, &c__0,
trans, &n, &n, &kl, &ku, &
nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
&ldb, &rcondc, &result[3]);
zgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
&lda, &b[1], &ldb, &x[1], &ldb, &
xact[1], &ldb, &rwork[1], &rwork[
nrhs + 1], &result[4]);
/* Print information about the tests that did */
/* not pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___59.ciunit = *nout;
s_wsfe(&io___59);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
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;
}
/* L60: */
}
nrun += 5;
/* L70: */
}
/* L80: */
}
/* + TEST 7: */
/* Get an estimate of RCOND = 1/CNDNUM. */
L90:
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
anorm = anormo;
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
anorm = anormi;
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)6, (
ftnlen)6);
zgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
&iwork[1], &anorm, &rcond, &work[1],
&rwork[1], &info);
/* Check error code from ZGBCON. */
if (info != 0) {
alaerh_(path, "ZGBCON", &info, &c__0,
norm, &n, &n, &kl, &ku, &c_n1, &
imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did */
/* not pass the threshold. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L100: */
}
L110:
;
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKGB */
} /* zchkgb_ */
/* Subroutine */ int zchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *af, doublecomplex *b, doublecomplex *
x, doublecomplex *xact, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
/* 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, m, n;
doublecomplex z__[3];
integer in, kl, ku, ix, lda;
doublereal cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[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;
integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
char trans[1];
integer izero, nerrs;
extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zgtt02_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zgtt05_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), 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, rcondi;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasum_(char *, integer *, integer *,
integer *, integer *);
doublereal rcondo, ainvnm;
logical trfcon;
extern /* Subroutine */ int zerrge_(char *, integer *);
extern doublereal zlangt_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgtcon_(char *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *),
zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *), zlarnv_(integer *, integer *,
integer *, doublecomplex *);
doublereal result[7];
extern /* Subroutine */ int zgtrfs_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zgttrf_(integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
integer *), zgttrs_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) 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. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX)+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (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) {
zerrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements whose real and */
/* imaginary parts are from [-1,1]. */
i__3 = n + (m << 1);
zlarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.) {
i__3 = n + (m << 1);
zdscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
if (n > 1) {
a[1].r = z__[2].r, a[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = n - 1 + izero;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
i__3 = izero;
a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n;
a[i__3].r = 0., a[i__3].i = 0.;
if (n > 1) {
z__[2].r = a[1].r, z__[2].i = a[1].i;
a[1].r = 0., a[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
i__3 = (n << 1) - 1;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = n - 1 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "ZGTTRF", (ftnlen)32, (ftnlen)6);
zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from ZGTTRF. */
if (info != izero) {
alaerh_(path, "ZGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = zlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use ZGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "ZGTCON", (ftnlen)32, (ftnlen)6);
zgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
info);
/* Check error code from ZGTCON. */
if (info != 0) {
alaerh_(path, "ZGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (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__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
zlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZGTTRS", (ftnlen)32, (ftnlen)6);
zgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from ZGTTRS. */
if (info != 0) {
alaerh_(path, "ZGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
zgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZGTRFS", (ftnlen)32, (ftnlen)6);
zgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
nrhs << 1) + 1], &info);
/* Check error code from ZGTRFS. */
if (info != 0) {
alaerh_(path, "ZGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
zgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass the */
/* threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKGT */
} /* zchkgt_ */
/* Subroutine */ int zlattr_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
doublereal c__;
integer i__, j;
doublecomplex s;
doublereal x, y, z__;
doublecomplex ra, rb;
integer kl, ku, iy;
doublereal ulp, sfac;
integer mode;
char path[3], dist[1];
doublereal unfl, rexp;
char type__[1];
doublereal texp;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
doublecomplex star1, plus1, plus2;
doublereal bscal;
extern logical lsame_(char *, char *);
doublereal tscal, anorm, bnorm, tleft;
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zrotg_(doublecomplex *,
doublecomplex *, doublereal *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
doublereal bignum, cndnum;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
integer jcount;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATTR generates a triangular test matrix in 2-dimensional storage. */
/* IMAT and UPLO uniquely specify the properties of the test matrix, */
/* which is returned in the array A. */
/* Arguments */
/* ========= */
/* IMAT (input) INTEGER */
/* An integer key describing which matrix to generate for this */
/* path. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A will be upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies whether the matrix or its transpose will be used. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* DIAG (output) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* N (input) INTEGER */
/* The order of the matrix to be generated. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N x N */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading N x N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix 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). */
/* B (output) COMPLEX*16 array, dimension (N) */
/* The right hand side vector, if IMAT > 10. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--b;
--work;
--rwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
smlnum = unfl;
bignum = (1. - ulp) / smlnum;
dlabad_(&smlnum, &bignum);
if (*imat >= 7 && *imat <= 10 || *imat == 18) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call ZLATB4 to set parameters for CLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
} else {
i__1 = -(*imat);
zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
}
/* IMAT <= 6: Non-unit triangular matrix */
if (*imat <= 6) {
zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[a_offset], lda, &work[1],
info);
/* IMAT > 6: Unit triangular matrix */
/* The diagonal is deliberately set to something other than 1. */
/* IMAT = 7: Matrix is the identity */
} else if (*imat == 7) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
}
/* IMAT > 7: Non-trivial unit triangular matrix */
/* Generate a unit triangular matrix T with condition CNDNUM by */
/* forming a triangular matrix with known singular values and */
/* filling in the zero entries with Givens rotations. */
} else if (*imat <= 10) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L70: */
}
/* L80: */
}
}
/* Since the trace of a unit triangular matrix is 1, the product */
/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
/* The following triangular matrix has singular values s, 1, 1, */
/* ..., 1, 1/s: */
/* 1 y y y ... y y z */
/* 1 0 0 ... 0 0 y */
/* 1 0 ... 0 0 y */
/* . ... . . . */
/* . . . . */
/* 1 0 y */
/* 1 y */
/* 1 */
/* To fill in the zeros, we first multiply by a matrix with small */
/* condition number of the form */
/* 1 0 0 0 0 ... */
/* 1 + * 0 0 ... */
/* 1 + 0 0 0 */
/* 1 + * 0 0 */
/* 1 + 0 0 */
/* ... */
/* 1 + 0 */
/* 1 0 */
/* 1 */
/* Each element marked with a '*' is formed by taking the product */
/* of the adjacent elements marked with '+'. The '*'s can be */
/* chosen freely, and the '+'s are chosen so that the inverse of */
/* T will have elements of the same magnitude as T. If the *'s in */
/* both T and inv(T) have small magnitude, T is well conditioned. */
/* The two offdiagonals of T are stored in WORK. */
/* The product of these two matrices has the form */
/* 1 y y y y y . y y z */
/* 1 + * 0 0 . 0 0 y */
/* 1 + 0 0 . 0 0 y */
/* 1 + * . . . . */
/* 1 + . . . . */
/* . . . . . */
/* . . . . */
/* 1 + y */
/* 1 y */
/* 1 */
/* Now we multiply by Givens rotations, using the fact that */
/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
/* and */
/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * .25, z__1.i = z__2.i * .25;
star1.r = z__1.r, star1.i = z__1.i;
sfac = .5;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
plus1.r = z__1.r, plus1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
z_div(&z__1, &star1, &plus1);
plus2.r = z__1.r, plus2.i = z__1.i;
i__2 = j;
work[i__2].r = plus1.r, work[i__2].i = plus1.i;
i__2 = *n + j;
work[i__2].r = star1.r, work[i__2].i = star1.i;
if (j + 1 <= *n) {
i__2 = j + 1;
work[i__2].r = plus2.r, work[i__2].i = plus2.i;
i__2 = *n + j + 1;
work[i__2].r = 0., work[i__2].i = 0.;
z_div(&z__1, &star1, &plus2);
plus1.r = z__1.r, plus1.i = z__1.i;
rexp = dlarnd_(&c__2, &iseed[1]);
if (rexp < 0.) {
d__2 = 1. - rexp;
d__1 = -pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
} else {
d__2 = rexp + 1.;
d__1 = pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
}
}
/* L90: */
}
x = sqrt(cndnum) - 1 / sqrt(cndnum);
if (*n > 2) {
y = sqrt(2. / (*n - 2)) * x;
} else {
y = 0.;
}
z__ = x * x;
if (upper) {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j * a_dim1 + 1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = j + *n * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L100: */
}
i__1 = *n * a_dim1 + 1;
a[i__1].r = z__, a[i__1].i = 0.;
} else {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j + a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = *n + j * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L110: */
}
i__1 = *n + a_dim1;
a[i__1].r = z__, a[i__1].i = 0.;
}
/* Fill in the zeros using Givens rotations. */
if (upper) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (j + 1) * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c s; -conjg(s) c] on the left. */
if (*n > j + 1) {
i__2 = *n - j - 1;
zrot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ 2) * a_dim1], lda, &c__, &s);
}
/* Multiply by [-c -s; conjg(s) -c] on the right. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
a_dim1 + 1], &c__1, &d__1, &z__1);
}
/* Negate A(J,J+1). */
i__2 = j + (j + 1) * a_dim1;
i__3 = j + (j + 1) * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L120: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + 1 + j * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
d_cnjg(&z__1, &s);
s.r = z__1.r, s.i = z__1.i;
/* Multiply by [ c -s; conjg(s) c] on the right. */
if (*n > j + 1) {
i__2 = *n - j - 1;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
2 + j * a_dim1], &c__1, &c__, &z__1);
}
/* Multiply by [-c s; -conjg(s) -c] on the left. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
zrot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
&d__1, &s);
}
/* Negate A(J+1,J). */
i__2 = j + 1 + j * a_dim1;
i__3 = j + 1 + j * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L130: */
}
}
/* IMAT > 10: Pathological test cases. These triangular matrices */
/* are badly scaled or badly conditioned, so when used in solving a */
/* triangular system they may cause overflow in the solution vector. */
} else if (*imat == 11) {
/* Type 11: Generate a triangular matrix with elements between */
/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
/* Make the right hand side large so that it requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L140: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tscal = 1. / max(d__1,d__2);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j - 1;
zdscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L160: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
i__2 = *n - j;
zdscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L170: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 13) {
/* Type 13: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L180: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L190: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 14) {
/* Type 14: T is diagonal with small numbers on the diagonal to */
/* make the growth factor underflow, but a small right hand side */
/* chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
for (j = *n; j >= 1; --j) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L200: */
}
if (jcount <= 2) {
i__1 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L210: */
}
} else {
jcount = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L220: */
}
if (jcount <= 2) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L230: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1].r = 0., b[1].i = 0.;
for (i__ = *n; i__ >= 2; i__ += -2) {
i__1 = i__;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = i__ - 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L240: */
}
} else {
i__1 = *n;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
i__2 = i__;
b[i__2].r = 0., b[i__2].i = 0.;
i__2 = i__ + 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L250: */
}
}
} else if (*imat == 15) {
/* Type 15: Make the diagonal elements small to cause gradual */
/* overflow when dividing by T(j,j). To control the amount of */
/* scaling needed, the matrix is bidiagonal. */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
texp = 1. / max(d__1,d__2);
tscal = pow_dd(&smlnum, &texp);
zlarnv_(&c__4, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L260: */
}
if (j > 1) {
i__2 = j - 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L270: */
}
i__1 = *n;
b[i__1].r = 1., b[i__1].i = 1.;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L280: */
}
if (j < *n) {
i__2 = j + 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L290: */
}
b[1].r = 1., b[1].i = 1.;
}
} else if (*imat == 16) {
/* Type 16: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L300: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L310: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
} else if (*imat == 17) {
/* Type 17: Make the offdiagonal elements large to cause overflow */
/* when adding a column of T. In the non-transposed case, the */
/* matrix is constructed to cause overflow when adding a column in */
/* every other step. */
tscal = unfl / ulp;
tscal = (1. - ulp) / tscal;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L320: */
}
/* L330: */
}
texp = 1.;
if (upper) {
for (j = *n; j >= 2; j += -2) {
i__1 = j * a_dim1 + 1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j + j * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j;
d__1 = texp * (1. - ulp);
b[i__1].r = d__1, b[i__1].i = 0.;
i__1 = (j - 1) * a_dim1 + 1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j - 1 + (j - 1) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j - 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__1].r = d__1, b[i__1].i = 0.;
texp *= 2.;
/* L340: */
}
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[1].r = d__1, b[1].i = 0.;
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; j += 2) {
i__2 = *n + j * a_dim1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j;
d__1 = texp * (1. - ulp);
b[i__2].r = d__1, b[i__2].i = 0.;
i__2 = *n + (j + 1) * a_dim1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + 1 + (j + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j + 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__2].r = d__1, b[i__2].i = 0.;
texp *= 2.;
/* L350: */
}
i__1 = *n;
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[i__1].r = d__1, b[i__1].i = 0.;
}
} else if (*imat == 18) {
/* Type 18: Generate a unit triangular matrix with elements */
/* between -1 and 1, and make the right hand side large so that it */
/* requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L360: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L370: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 19) {
/* Type 19: Generate a triangular matrix with elements between */
/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
/* norms will exceed BIGNUM. */
/* 1/3/91: ZLATRS no longer can handle this case */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tleft = bignum / max(d__1,d__2);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n);
tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__5, &iseed[1], &j, &a[j * a_dim1 + 1]);
dlarnv_(&c__1, &iseed[1], &j, &rwork[1]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L380: */
}
/* L390: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
zlarnv_(&c__5, &iseed[1], &i__2, &a[j + j * a_dim1]);
i__2 = *n - j + 1;
dlarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__ - j + 1] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L400: */
}
/* L410: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
}
/* Flip the matrix if the transpose will be used. */
if (! lsame_(trans, "N")) {
if (upper) {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
zswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
* a_dim1], &c_n1);
/* L420: */
}
} else {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
i__3 = -(*lda);
zswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
1) * a_dim1], &i__3);
/* L430: */
}
}
}
return 0;
/* End of ZLATTR */
} /* zlattr_ */
/* Subroutine */ int zdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
doublereal *d__, doublecomplex *e, doublecomplex *b, doublecomplex *x,
doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer
*nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n;
doublereal z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
doublereal cond;
integer mode;
doublereal dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
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 *
), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer izero, nerrs;
extern /* Subroutine */ int zptt01_(integer *, doublereal *,
doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zptt02_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *), zptt05_(
integer *, integer *, doublereal *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *), zptsv_(integer *, integer *, doublereal *,
doublecomplex *, doublecomplex *, integer *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *), alaerh_(char
*, char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal rcondc;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
doublereal ainvnm;
extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlaptm_(char *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, integer *,
doublecomplex *);
doublereal result[6];
extern /* Subroutine */ int zpttrf_(integer *, doublereal *,
doublecomplex *, integer *), zerrvx_(char *, integer *),
zpttrs_(char *, integer *, integer *, doublereal *, doublecomplex
*, doublecomplex *, integer *, integer *), zptsvx_(char *,
integer *, integer *, doublereal *, doublecomplex *, doublereal *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVPT tests ZPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*2) */
/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
/* E (workspace) COMPLEX*16 array, dimension (NMAX*2) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
i__5 = ia;
d__[i__4] = a[i__5].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = n;
i__4 = ia;
d__[i__3] = a[i__4].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
dlarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
zlarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = abs(d__[1]);
} else {
d__[1] = abs(d__[1]) + z_abs(&e[1]);
d__[n] = (d__1 = d__[n], abs(d__1)) + z_abs(&e[n - 1])
;
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1)) + z_abs(&
e[i__]) + z_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = idamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
d__1 = anorm / dmax__;
dscal_(&n, &d__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
d__1 = anorm / dmax__;
zdscal_(&i__3, &d__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1].r = z__[2], e[1].i = 0.;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[n] = z__[1];
} else {
i__3 = izero - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[izero] = z__[1];
i__3 = izero;
e[i__3].r = z__[2], e[i__3].i = 0.;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.;
if (n > 1) {
z__[2] = e[1].r;
e[1].r = 0., e[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0] = e[i__3].r;
i__3 = n - 1;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[n];
d__[n] = 0.;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0] = e[i__3].r;
i__3 = izero - 1;
e[i__3].r = 0., e[i__3].i = 0.;
i__3 = izero;
z__[2] = e[i__3].r;
i__3 = izero;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[izero];
d__[izero] = 0.;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
zlaptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
&c_b25, &b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by ZPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = zlanht_("1", &n, &d__[1], &e[1]);
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
zpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use ZPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
x[1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test ZPTSV -- */
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "ZPTSV ", (ftnlen)6, (ftnlen)6);
zptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from ZPTSV . */
if (info != izero) {
alaerh_(path, "ZPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
lda, &work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "ZPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test ZPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.;
i__4 = n + i__;
e[i__4].r = 0., e[i__4].i = 0.;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.;
}
}
zlaset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using ZPTSVX. */
s_copy(srnamc_1.srnamt, "ZPTSVX", (ftnlen)6, (ftnlen)6);
zptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from ZPTSVX. */
if (info != izero) {
alaerh_(path, "ZPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
zptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "ZPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPT */
} /* zdrvpt_ */
/* Subroutine */ int zchkql_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
nmax, doublecomplex *a, doublecomplex *af, doublecomplex *aq,
doublecomplex *al, doublecomplex *ac, doublecomplex *b, doublecomplex
*x, doublecomplex *xact, doublecomplex *tau, doublecomplex *work,
doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Local variables */
integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
imat, info;
char path[3];
integer kval[4];
char dist[1], type__[1];
integer nrun;
integer nfail, iseed[4];
doublereal anorm;
integer minmn, nerrs;
integer lwork;
doublereal cndnum;
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKQL tests ZGEQLF, ZUNGQL and CUNMQL. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* 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 column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AL (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* 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;
--tau;
--xact;
--x;
--b;
--ac;
--al;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--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, "QL", (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) {
zerrql_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
lda = *nmax;
lwork = *nmax * max(*nmax,*nrhs);
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of N in NVAL. */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
minmn = min(m,n);
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L50;
}
/* Set up parameters with ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L50;
}
/* Set some values for K: the first value must be MINMN, */
/* corresponding to the call of ZQLT01; other values are */
/* used in the calls of ZQLT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
for (i__ = 1; i__ <= 8; ++i__) {
result[i__ - 1] = 0.;
}
nt = 2;
if (ik == 1) {
/* Test ZGEQLF */
zqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
if (m >= n) {
/* Check the lower-left n-by-n corner */
if (! zgennd_(&n, &n, &af[m - n + 1], &lda)) {
result[7] = *thresh * 2;
}
} else {
/* Check the (n-m)th superdiagonal */
if (! zgennd_(&m, &m, &af[(n - m) * lda + 1],
&lda)) {
result[7] = *thresh * 2;
}
}
} else if (m >= n) {
/* Test ZUNGQL, using factorization */
/* returned by ZQLT01 */
zqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
} else {
result[0] = 0.;
result[1] = 0.;
}
if (m >= k) {
/* Test ZUNMQL, using factorization returned */
/* by ZQLT01 */
zqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call ZGEQLS to solve a system */
/* with NRHS right hand sides and compute the */
/* residual. */
if (k == n && inb == 1) {
/* Generate a solution and set the right */
/* hand side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
(ftnlen)6);
zlarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
zlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "ZGEQLS", (ftnlen)32,
(ftnlen)6);
zgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from ZGEQLS. */
if (info != 0) {
alaerh_(path, "ZGEQLS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
zget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[m - n + 1], &lda, &b[1], &lda,
&rwork[1], &result[6]);
++nt;
} else {
result[6] = 0.;
}
} else {
result[2] = 0.;
result[3] = 0.;
result[4] = 0.;
result[5] = 0.;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__5 = nt;
for (i__ = 1; i__ <= i__5; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKQL */
} /* zchkql_ */
/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork;
extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zqrt11_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zqrt12_(integer *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *)
, dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zgeqpf_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal result[3];
extern /* Subroutine */ int zerrqp_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKQP tests ZGEQPF. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* 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 column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
/* 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;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--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, "QP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrqp_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L60;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
zlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
/* Compute the QR factorization with pivoting of A */
s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6);
zgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
&lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
tau[1], &iwork[1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = zqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imode, (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;
}
/* L50: */
}
nrun += 3;
L60:
;
}
/* L70: */
}
/* L80: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of ZCHKQP */
return 0;
} /* zchkqp_ */
/* 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 */
static integer ioff, mode, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer n, nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static integer iuplo, izero, i1, i2, nerrs, lwork;
extern /* Subroutine */ int zpot05_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int 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 *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum;
static 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 *);
static 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 *);
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
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.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "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_ */
