/* Subroutine */ int dchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed,
doublereal *thresh, doublereal *a, integer *lda, doublereal *bd,
doublereal *be, doublereal *s1, doublereal *s2, doublereal *x,
integer *ldx, doublereal *y, doublereal *z__, doublereal *q, integer *
ldq, doublereal *pt, integer *ldpt, doublereal *u, doublereal *vt,
doublereal *work, integer *lwork, integer *iwork, integer *nout,
integer *info)
{
/* Initialized data */
static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
/* Format strings */
static char fmt_9998[] = "(\002 DCHKBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
"=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double log(doublereal), sqrt(doublereal), exp(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, m, n, mq;
doublereal dum[1], ulp, cond;
integer jcol;
char path[3];
integer idum[1], mmax, nmax;
doublereal unfl, ovfl;
char uplo[1];
doublereal temp1, temp2;
extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, dbdt02_(integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
logical badmm;
extern /* Subroutine */ int dbdt03_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *);
logical badnn;
integer nfail;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer imode;
doublereal dumma[1];
integer iinfo;
extern /* Subroutine */ int dort01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *);
doublereal anorm;
integer mnmin;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer mnmax, jsize, itype, jtype, ntest;
extern /* Subroutine */ int dlahd2_(integer *, char *);
integer log2ui;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
logical bidiag;
extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dorgbr_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), xerbla_(char *, integer *), alasum_(
char *, integer *, integer *, integer *, integer *),
dlatmr_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublereal *, integer *,
integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublereal *, integer *, doublereal *, integer
*);
doublereal amninv;
integer minwrk;
doublereal rtunfl, rtovfl, ulpinv, result[19];
integer mtypes;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 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 */
/* ======= */
/* DCHKBD checks the singular value decomposition (SVD) routines. */
/* DGEBRD reduces a real general m by n matrix A to upper or lower */
/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B */
/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
/* and lower bidiagonal if m < n. */
/* DORGBR generates the orthogonal matrices Q and P' from DGEBRD. */
/* Note that Q and P are not necessarily square. */
/* DBDSQR computes the singular value decomposition of the bidiagonal */
/* matrix B as B = U S V'. It is called three times to compute */
/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
/* values and the columns of the matrices U and V are the left */
/* and right singular vectors, respectively, of B. */
/* 2) Same as 1), but the singular values are stored in S2 and the */
/* singular vectors are not computed. */
/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
/* In addition, DBDSQR has an option to apply the left orthogonal matrix */
/* U to a matrix X, useful in least squares applications. */
/* DBDSDC computes the singular value decomposition of the bidiagonal */
/* matrix B as B = U S V' using divide-and-conquer. It is called twice */
/* to compute */
/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
/* values and the columns of the matrices U and V are the left */
/* and right singular vectors, respectively, of B. */
/* 2) Same as 1), but the singular values are stored in S2 and the */
/* singular vectors are not computed. */
/* 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 X are generated. */
/* The problem dimensions are as follows */
/* A: M x N */
/* Q: M x min(M,N) (but M x M if NRHS > 0) */
/* P: min(M,N) x N */
/* B: min(M,N) x min(M,N) */
/* U, V: min(M,N) x min(M,N) */
/* S1, S2 diagonal, order min(M,N) */
/* X: M x NRHS */
/* For each generated matrix, 14 tests are performed: */
/* Test DGEBRD and DORGBR */
/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
/* (2) | I - Q' Q | / ( M ulp ) */
/* (3) | I - PT PT' | / ( N ulp ) */
/* Test DBDSQR on bidiagonal matrix B */
/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
/* and Z = U' Y. */
/* (6) | I - U' U | / ( min(M,N) ulp ) */
/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* (10) 0 if the true singular values of B are within THRESH of */
/* those in S1. 2*THRESH if they are not. (Tested using */
/* DSVDCH) */
/* Test DBDSQR on matrix A */
/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
/* (13) | I - (QU)'(QU) | / ( M ulp ) */
/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
/* Test DBDSDC on bidiagonal matrix B */
/* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
/* (16) | I - U' U | / ( min(M,N) ulp ) */
/* (17) | I - VT VT' | / ( min(M,N) ulp ) */
/* (18) S1 contains min(M,N) nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* 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 ) */
/* Special case: */
/* (16) A bidiagonal matrix with random entries chosen from a */
/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
/* entry is e^x, where x is chosen uniformly on */
/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
/* (a) DGEBRD is not called to reduce it to bidiagonal form. */
/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
/* matrix will be lower bidiagonal, otherwise upper. */
/* (c) only tests 5--8 and 14 are performed. */
/* A subset of the full set of matrix types may be selected through */
/* the logical array DOTYPE. */
/* 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). */
/* 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. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DCHKBD */
/* 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 matrices are in A and B. */
/* 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 (m,n), a matrix */
/* 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" matrices X, Y, */
/* and Z, used in testing DBDSQR. 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 values of ISEED are changed on exit, and can be */
/* used in the next call to DCHKBD to continue the same random */
/* number sequence. */
/* 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. Note that the */
/* expected value of the test ratios is O(1), so THRESH should */
/* be a reasonably small multiple of 1, e.g., 10 or 100. */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* where NMAX is the maximum value of N in NVAL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,MMAX), */
/* where MMAX is the maximum value of M in MVAL. */
/* BD (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* BE (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S1 (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S2 (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* X (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* LDX (input) INTEGER */
/* The leading dimension of the arrays X, Y, and Z. */
/* LDX >= max(1,MMAX) */
/* Y (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* Z (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX) */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
/* PT (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX) */
/* LDPT (input) INTEGER */
/* The leading dimension of the arrays PT, U, and V. */
/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
/* U (workspace) DOUBLE PRECISION array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* V (workspace) DOUBLE PRECISION array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
/* pairs (M,N)=(MM(j),NN(j)) */
/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some MM(j) < 0 */
/* -3: Some NN(j) < 0 */
/* -4: NTYPES < 0 */
/* -6: NRHS < 0 */
/* -8: THRESH < 0 */
/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/* -17: LDB < 1 or LDB < MMAX. */
/* -21: LDQ < 1 or LDQ < MMAX. */
/* -23: LDPT< 1 or LDPT< MNMAX. */
/* -27: LWORK too small. */
/* If DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR, */
/* 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. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* MMAX Largest value in NN. */
/* NMAX Largest value in NN. */
/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
/* matrix.) */
/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
/* NFAIL The number of tests which have exceeded THRESH */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* 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 .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--mval;
--nval;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--bd;
--be;
--s1;
--s2;
z_dim1 = *ldx;
z_offset = 1 + z_dim1;
z__ -= z_offset;
y_dim1 = *ldx;
y_offset = 1 + y_dim1;
y -= y_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
vt_dim1 = *ldpt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldpt;
u_offset = 1 + u_dim1;
u -= u_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
--work;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
minwrk = 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);
/* Computing MAX */
/* Computing MAX */
i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
i__6 = nval[j], i__7 = mval[j];
i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
min(i__6,i__7);
minwrk = max(i__2,i__3);
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*ntypes < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -6;
} else if (*lda < mmax) {
*info = -11;
} else if (*ldx < mmax) {
*info = -17;
} else if (*ldq < mmax) {
*info = -21;
} else if (*ldpt < mnmax) {
*info = -23;
} else if (minwrk > *lwork) {
*info = -27;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DCHKBD", &i__1);
return 0;
}
/* Initialize constants */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
nfail = 0;
ntest = 0;
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
log2ui = (integer) (log(ulpinv) / log(2.));
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
infoc_1.infot = 0;
/* Loop over sizes, types */
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(m,n);
amninv = 1. / max(i__2,1);
if (*nsizes != 1) {
mtypes = min(16,*ntypes);
} else {
mtypes = min(17,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L190;
}
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.;
/* L30: */
}
*(unsigned char *)uplo = ' ';
/* 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/ eigenvalues) */
/* =5 random symmetric, w/ eigenvalues */
/* =6 nonsymmetric, w/ singular values */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random nonsymmetric */
/* =10 random bidiagonal (log. distrib.) */
if (mtypes > 16) {
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 * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
bidiag = FALSE_;
if (itype == 1) {
/* Zero matrix */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = mnmin;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode,
&cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda,
&work[mnmin + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode,
&cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
mnmin + 1], &iinfo);
} else if (itype == 6) {
/* Nonsymmetric, singular values specified */
dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond,
&anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin +
1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random entries */
dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
a_offset], lda, &iwork[1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random entries */
dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset],
lda, &iwork[1], &iinfo);
} else if (itype == 9) {
/* Nonsymmetric, random entries */
dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
&c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
iwork[1], &iinfo);
} else if (itype == 10) {
/* Bidiagonal, random entries */
temp1 = log(ulp) * -2.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
if (j < mnmin) {
be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
}
/* L90: */
}
iinfo = 0;
bidiag = TRUE_;
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
} else {
iinfo = 1;
}
if (iinfo == 0) {
/* Generate Right-Hand Side */
if (bidiag) {
dlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1],
&c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
} else {
dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
x_offset], ldx, &iwork[1], &iinfo);
}
}
/* Error Exit */
if (iinfo != 0) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call DGEBRD and DORGBR to compute B, Q, and P, do tests. */
if (! bidiag) {
/* Compute transformations to reduce A to bidiagonal form: */
/* B := Q' * A * P. */
dlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
i__3 = *lwork - (mnmin << 1);
dgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
iinfo);
/* Check error code from DGEBRD. */
if (iinfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "DGEBRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
dlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
/* Generate Q */
mq = m;
if (*nrhs <= 0) {
mq = mnmin;
}
i__3 = *lwork - (mnmin << 1);
dorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from DORGBR. */
if (iinfo != 0) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "DORGBR(Q)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Generate P' */
i__3 = *lwork - (mnmin << 1);
dorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from DORGBR. */
if (iinfo != 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "DORGBR(P)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
dgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
y_offset], ldx);
/* Test 1: Check the decomposition A := Q * B * PT */
/* 2: Check the orthogonality of Q */
/* 3: Check the orthogonality of PT */
dbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
;
dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &result[1]);
dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &result[2]);
}
/* Use DBDSQR to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT, and compute Z = U' * Y. */
dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
ldpt);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
ldpt);
dbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&work[mnmin + 1], &iinfo);
/* Check error code from DBDSQR. */
if (iinfo != 0) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "DBDSQR(vects)", (ftnlen)13);
do_fio(&c__1, (char *)&iinfo, (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 *)&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 L170;
}
}
/* Use DBDSQR to compute only the singular values of the */
/* bidiagonal matrix B; U, VT, and Z should not be modified. */
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&work[mnmin + 1], &iinfo);
/* Check error code from DBDSQR. */
if (iinfo != 0) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "DBDSQR(values)", (ftnlen)14);
do_fio(&c__1, (char *)&iinfo, (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 *)&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[8] = ulpinv;
goto L170;
}
}
/* Test 4: Check the decomposition B := U * S1 * VT */
/* 5: Check the computation Z := U' * Y */
/* 6: Check the orthogonality of U */
/* 7: Check the orthogonality of VT */
dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
dbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
u_offset], ldpt, &work[1], &result[4]);
dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &result[5]);
dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &result[6]);
/* Test 8: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[7] = 0.;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[7] = ulpinv;
}
if (s1[i__] < 0.) {
result[7] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.) {
result[7] = ulpinv;
}
}
/* Test 9: Compare DBDSQR with and without singular vectors */
temp2 = 0.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
d__2));
d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
;
temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
temp2 = max(temp1,temp2);
/* L120: */
}
result[8] = temp2;
/* Test 10: Sturm sequence test of singular values */
/* Go up by factors of two until it succeeds */
temp1 = *thresh * (.5 - ulp);
i__3 = log2ui;
for (j = 0; j <= i__3; ++j) {
/* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
if (iinfo == 0) {
goto L140;
}
temp1 *= 2.;
/* L130: */
}
L140:
result[9] = temp1;
/* Use DBDSQR to form the decomposition A := (QU) S (VT PT) */
/* from the bidiagonal form A := Q B PT. */
if (! bidiag) {
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
ldx, &work[mnmin + 1], &iinfo);
/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
/* 12: Check the computation Z := U' * Q' * X */
/* 13: Check the orthogonality of Q*U */
/* 14: Check the orthogonality of VT*PT */
dbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
10]);
dbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
q_offset], ldq, &work[1], &result[11]);
dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &result[12]);
dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &result[13]);
}
/* Use DBDSDC to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT */
dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
ldpt);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
ldpt);
dbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
1], &iinfo);
/* Check error code from DBDSDC. */
if (iinfo != 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "DBDSDC(vects)", (ftnlen)13);
do_fio(&c__1, (char *)&iinfo, (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 *)&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[14] = ulpinv;
goto L170;
}
}
/* Use DBDSDC to compute only the singular values of the */
/* bidiagonal matrix B; U and VT should not be modified. */
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);
/* Check error code from DBDSDC. */
if (iinfo != 0) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "DBDSDC(values)", (ftnlen)14);
do_fio(&c__1, (char *)&iinfo, (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 *)&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[17] = ulpinv;
goto L170;
}
}
/* Test 15: Check the decomposition B := U * S1 * VT */
/* 16: Check the orthogonality of U */
/* 17: Check the orthogonality of VT */
dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &result[15]);
dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &result[16]);
/* Test 18: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[17] = 0.;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[17] = ulpinv;
}
if (s1[i__] < 0.) {
result[17] = ulpinv;
}
/* L150: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.) {
result[17] = ulpinv;
}
}
/* Test 19: Compare DBDSQR with and without singular vectors */
temp2 = 0.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
d__4 = abs(s1[1]), d__5 = abs(s2[1]);
d__2 = sqrt(unfl) * max(s1[1],1.), d__3 = ulp * max(d__4,d__5)
;
temp1 = (d__1 = s1[j] - s2[j], abs(d__1)) / max(d__2,d__3);
temp2 = max(temp1,temp2);
/* L160: */
}
result[18] = temp2;
/* End of Loop -- Check for RESULT(j) > THRESH */
L170:
for (j = 1; j <= 19; ++j) {
if (result[j - 1] >= *thresh) {
if (nfail == 0) {
dlahd2_(nout, path);
}
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&m, (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))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L180: */
}
if (! bidiag) {
ntest += 19;
} else {
ntest += 5;
}
L190:
;
}
/* L200: */
}
/* Summary */
alasum_(path, nout, &nfail, &ntest, &c__0);
return 0;
/* End of DCHKBD */
} /* dchkbd_ */
/* Subroutine */ int dhst01_(integer *n, integer *ilo, integer *ihi,
doublereal *a, integer *lda, doublereal *h__, integer *ldh,
doublereal *q, integer *ldq, doublereal *work, integer *lwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, q_dim1, q_offset;
doublereal d__1, d__2;
/* Local variables */
doublereal eps, unfl, ovfl;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dort01_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *);
doublereal anorm, wnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
integer ldwork;
doublereal smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DHST01 tests the reduction of a general matrix A to upper Hessenberg */
/* form: A = Q*H*Q'. Two test ratios are computed; */
/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
/* The matrix Q is assumed to be given explicitly as it would be */
/* following DGEHRD + DORGHR. */
/* In this version, ILO and IHI are not used and are assumed to be 1 and */
/* N, respectively. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* A is assumed to be upper triangular in rows and columns */
/* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in */
/* rows and columns ILO+1:IHI. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original n by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */
/* The upper Hessenberg matrix H from the reduction A = Q*H*Q' */
/* as computed by DGEHRD. H is assumed to be zero below the */
/* first subdiagonal. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* Q (input) DOUBLE PRECISION array, dimension (LDQ,N) */
/* The orthogonal matrix Q from the reduction A = Q*H*Q' as */
/* computed by DGEHRD + DORGHR. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= 2*N*N. */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
--result;
/* Function Body */
if (*n <= 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
unfl = dlamch_("Safe minimum");
eps = dlamch_("Precision");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
smlnum = unfl * *n / eps;
/* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
/* Copy A to WORK */
ldwork = max(1,*n);
dlacpy_(" ", n, n, &a[a_offset], lda, &work[1], &ldwork);
/* Compute Q*H */
dgemm_("No transpose", "No transpose", n, n, n, &c_b7, &q[q_offset], ldq,
&h__[h_offset], ldh, &c_b8, &work[ldwork * *n + 1], &ldwork);
/* Compute A - Q*H*Q' */
dgemm_("No transpose", "Transpose", n, n, n, &c_b11, &work[ldwork * *n +
1], &ldwork, &q[q_offset], ldq, &c_b7, &work[1], &ldwork);
/* Computing MAX */
d__1 = dlange_("1", n, n, &a[a_offset], lda, &work[ldwork * *n + 1]);
anorm = max(d__1,unfl);
wnorm = dlange_("1", n, n, &work[1], &ldwork, &work[ldwork * *n + 1]);
/* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS) */
/* Computing MAX */
d__1 = smlnum, d__2 = anorm * eps;
result[1] = min(wnorm,anorm) / max(d__1,d__2) / *n;
/* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS ) */
dort01_("Columns", n, n, &q[q_offset], ldq, &work[1], lwork, &result[2]);
return 0;
/* End of DHST01 */
} /* dhst01_ */
/* Subroutine */ int dget24_(logical *comp, integer *jtype, doublereal *
thresh, integer *iseed, integer *nounit, integer *n, doublereal *a,
integer *lda, doublereal *h__, doublereal *ht, doublereal *wr,
doublereal *wi, doublereal *wrt, doublereal *wit, doublereal *wrtmp,
doublereal *witmp, doublereal *vs, integer *ldvs, doublereal *vs1,
doublereal *rcdein, doublereal *rcdvin, integer *nslct, integer *
islct, doublereal *result, doublereal *work, integer *lwork, integer *
iwork, logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9998[] = "(\002 DGET24: \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[] = "(\002 DGET24: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
"i4)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal v, eps, tol, tmp, ulp;
integer sdim, kmin, itmp, ipnt[20], rsub;
char sort[1];
integer sdim1;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer iinfo;
extern /* Subroutine */ int dort01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal vimin, tolin, vrmin;
integer isort;
doublereal wnorm, rcnde1, rcndv1;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal rconde;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern logical dslect_(doublereal *, doublereal *);
extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, integer *, integer *, integer *, logical *, integer *), xerbla_(char *, integer *);
integer knteig;
doublereal rcondv;
integer liwork;
doublereal smlnum, ulpinv;
/* Fortran I/O blocks */
static cilist io___13 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___34 = { 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___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 */
/* ======= */
/* DGET24 checks the nonsymmetric eigenvalue (Schur form) problem */
/* expert driver DGEESX. */
/* If COMP = .FALSE., the first 13 of the following tests will be */
/* be performed on the input matrix A, and also tests 14 and 15 */
/* if LWORK is sufficiently large. */
/* If COMP = .TRUE., all 17 test will be performed. */
/* (1) 0 if T is in Schur form, 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (2) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (no sorting of eigenvalues). */
/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (5) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (7) 0 if T is in Schur form, 1/ulp otherwise */
/* (with sorting of eigenvalues) */
/* (8) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (with sorting of eigenvalues). */
/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare WR, WI with and */
/* without reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (11) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare T with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare VS with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (13) if sorting worked and SDIM is the number of */
/* eigenvalues which were SELECTed */
/* If workspace sufficient, also compare SDIM with and */
/* without reciprocal condition numbers */
/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal average eigenvalue condition number */
/* computed by DGEESX 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. */
/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right invariant subspace condition */
/* number computed by DGEESX 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. */
/* Arguments */
/* ========= */
/* COMP (input) LOGICAL */
/* COMP describes which input tests to perform: */
/* = .FALSE. if the computed condition numbers are not to */
/* be tested against RCDVIN and RCDEIN */
/* = .TRUE. if they are to be compared */
/* JTYPE (input) INTEGER */
/* Type of input matrix. Used to label output if error occurs. */
/* ISEED (input) INTEGER array, dimension (4) */
/* If COMP = .FALSE., the random number generator seed */
/* used to produce matrix. */
/* If COMP = .TRUE., ISEED(1) = the number of the example. */
/* Used to label output if error occurs. */
/* 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.) */
/* N (input) INTEGER */
/* The dimension of A. N must be at least 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least N. */
/* H (workspace) DOUBLE PRECISION array, dimension (LDA, N) */
/* Another copy of the test matrix A, modified by DGEESX. */
/* HT (workspace) DOUBLE PRECISION array, dimension (LDA, N) */
/* Yet another copy of the test matrix A, modified by DGEESX. */
/* WR (workspace) DOUBLE PRECISION array, dimension (N) */
/* WI (workspace) DOUBLE PRECISION array, dimension (N) */
/* The real and imaginary parts of the eigenvalues of A. */
/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
/* WRT (workspace) DOUBLE PRECISION array, dimension (N) */
/* WIT (workspace) DOUBLE PRECISION array, dimension (N) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but those computed when DGEESX only computes a partial */
/* eigendecomposition, i.e. not Schur vectors */
/* WRTMP (workspace) DOUBLE PRECISION array, dimension (N) */
/* WITMP (workspace) DOUBLE PRECISION array, dimension (N) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but sorted by increasing real part. */
/* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, N) */
/* VS holds the computed Schur vectors. */
/* LDVS (input) INTEGER */
/* Leading dimension of VS. Must be at least max(1, N). */
/* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, N) */
/* VS1 holds another copy of the computed Schur vectors. */
/* RCDEIN (input) DOUBLE PRECISION */
/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
/* condition number for the average of selected eigenvalues. */
/* RCDVIN (input) DOUBLE PRECISION */
/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
/* condition number for the selected right invariant subspace. */
/* NSLCT (input) INTEGER */
/* When COMP = .TRUE. the number of selected eigenvalues */
/* corresponding to the precomputed values RCDEIN and RCDVIN. */
/* ISLCT (input) INTEGER array, dimension (NSLCT) */
/* When COMP = .TRUE. ISLCT selects the eigenvalues of the */
/* input matrix corresponding to the precomputed values RCDEIN */
/* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the */
/* eigenvalue with the J-th largest real part is selected. */
/* Not referenced if COMP = .FALSE. */
/* RESULT (output) DOUBLE PRECISION array, dimension (17) */
/* The values computed by the 17 tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK to be passed to DGEESX. This */
/* must be at least 3*N, and N+N**2 if tests 14--16 are to */
/* be performed. */
/* IWORK (workspace) INTEGER array, dimension (N*N) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* If 0, successful exit. */
/* If <0, input parameter -INFO had an incorrect value. */
/* If >0, DGEESX returned an error code, the absolute */
/* value of which is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
--wrt;
--wit;
--wrtmp;
--witmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--islct;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
*info = 0;
if (*thresh < 0.) {
*info = -3;
} else if (*nounit <= 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < 1 || *lda < *n) {
*info = -8;
} else if (*ldvs < 1 || *ldvs < *n) {
*info = -18;
} else if (*lwork < *n * 3) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGET24", &i__1);
return 0;
}
/* Quick return if nothing to do */
for (i__ = 1; i__ <= 17; ++i__) {
result[i__] = -1.;
/* L10: */
}
if (*n == 0) {
return 0;
}
/* Important constants */
smlnum = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
/* Perform tests (1)-(13) */
sslct_1.selopt = 0;
liwork = *n * *n;
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 6;
}
/* Compute Schur form and Schur vectors, and test them */
dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
dgeesx_("V", sort, (L_fp)dslect_, "N", n, &h__[h_offset], lda, &sdim,
&wr[1], &wi[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[
1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[rsub + 1] = ulpinv;
if (*jtype != 22) {
io___13.ciunit = *nounit;
s_wsfe(&io___13);
do_fio(&c__1, "DGEESX1", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___14.ciunit = *nounit;
s_wsfe(&io___14);
do_fio(&c__1, "DGEESX1", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
return 0;
}
if (isort == 0) {
dcopy_(n, &wr[1], &c__1, &wrtmp[1], &c__1);
dcopy_(n, &wi[1], &c__1, &witmp[1], &c__1);
}
/* Do Test (1) or Test (7) */
result[rsub + 1] = 0.;
i__1 = *n - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
if (h__[i__ + j * h_dim1] != 0.) {
result[rsub + 1] = ulpinv;
}
/* L20: */
}
/* L30: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
if (h__[i__ + 1 + i__ * h_dim1] != 0. && h__[i__ + 2 + (i__ + 1) *
h_dim1] != 0.) {
result[rsub + 1] = ulpinv;
}
/* L40: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
if (h__[i__ + i__ * h_dim1] != h__[i__ + 1 + (i__ + 1) *
h_dim1] || h__[i__ + (i__ + 1) * h_dim1] == 0. ||
d_sign(&c_b35, &h__[i__ + 1 + i__ * h_dim1]) ==
d_sign(&c_b35, &h__[i__ + (i__ + 1) * h_dim1])) {
result[rsub + 1] = ulpinv;
}
}
/* L50: */
}
/* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP) */
/* Copy A to VS1, used as workspace */
dlacpy_(" ", n, n, &a[a_offset], lda, &vs1[vs1_offset], ldvs);
/* Compute Q*H and store in HT. */
dgemm_("No transpose", "No transpose", n, n, n, &c_b35, &vs[vs_offset]
, ldvs, &h__[h_offset], lda, &c_b41, &ht[ht_offset], lda);
/* Compute A - Q*H*Q' */
dgemm_("No transpose", "Transpose", n, n, n, &c_b44, &ht[ht_offset],
lda, &vs[vs_offset], ldvs, &c_b35, &vs1[vs1_offset], ldvs);
/* Computing MAX */
d__1 = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
anorm = max(d__1,smlnum);
wnorm = dlange_("1", n, n, &vs1[vs1_offset], ldvs, &work[1]);
if (anorm > wnorm) {
result[rsub + 2] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[rsub + 2] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[rsub + 2] = min(d__1,d__2) / (*n * ulp);
}
}
/* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP ) */
dort01_("Columns", n, n, &vs[vs_offset], ldvs, &work[1], lwork, &
result[rsub + 3]);
/* Do Test (4) or Test (10) */
result[rsub + 4] = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (h__[i__ + i__ * h_dim1] != wr[i__]) {
result[rsub + 4] = ulpinv;
}
/* L60: */
}
if (*n > 1) {
if (h__[h_dim1 + 2] == 0. && wi[1] != 0.) {
result[rsub + 4] = ulpinv;
}
if (h__[*n + (*n - 1) * h_dim1] == 0. && wi[*n] != 0.) {
result[rsub + 4] = ulpinv;
}
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
tmp = sqrt((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1))) *
sqrt((d__2 = h__[i__ + (i__ + 1) * h_dim1], abs(d__2))
);
/* Computing MAX */
/* Computing MAX */
d__4 = ulp * tmp;
d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__] - tmp, abs(
d__1)) / max(d__4,smlnum);
result[rsub + 4] = max(d__2,d__3);
/* Computing MAX */
/* Computing MAX */
d__4 = ulp * tmp;
d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__ + 1] + tmp,
abs(d__1)) / max(d__4,smlnum);
result[rsub + 4] = max(d__2,d__3);
} else if (i__ > 1) {
if (h__[i__ + 1 + i__ * h_dim1] == 0. && h__[i__ + (i__ - 1) *
h_dim1] == 0. && wi[i__] != 0.) {
result[rsub + 4] = ulpinv;
}
}
/* L70: */
}
/* Do Test (5) or Test (11) */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("N", sort, (L_fp)dslect_, "N", n, &ht[ht_offset], lda, &sdim,
&wrt[1], &wit[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[rsub + 5] = ulpinv;
if (*jtype != 22) {
io___19.ciunit = *nounit;
s_wsfe(&io___19);
do_fio(&c__1, "DGEESX2", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___20.ciunit = *nounit;
s_wsfe(&io___20);
do_fio(&c__1, "DGEESX2", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
result[rsub + 5] = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[rsub + 5] = ulpinv;
}
/* L80: */
}
/* L90: */
}
/* Do Test (6) or Test (12) */
result[rsub + 6] = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[rsub + 6] = ulpinv;
}
/* L100: */
}
/* Do Test (13) */
if (isort == 1) {
result[13] = 0.;
knteig = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = -wi[i__];
if (dslect_(&wr[i__], &wi[i__]) || dslect_(&wr[i__], &d__1)) {
++knteig;
}
if (i__ < *n) {
d__1 = -wi[i__ + 1];
d__2 = -wi[i__];
if ((dslect_(&wr[i__ + 1], &wi[i__ + 1]) || dslect_(&wr[
i__ + 1], &d__1)) && ! (dslect_(&wr[i__], &wi[i__]
) || dslect_(&wr[i__], &d__2)) && iinfo != *n + 2)
{
result[13] = ulpinv;
}
}
/* L110: */
}
if (sdim != knteig) {
result[13] = ulpinv;
}
}
/* L120: */
}
/* If there is enough workspace, perform tests (14) and (15) */
/* as well as (10) through (13) */
if (*lwork >= *n + *n * *n / 2) {
/* Compute both RCONDE and RCONDV with VS */
*(unsigned char *)sort = 'S';
result[14] = 0.;
result[15] = 0.;
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("V", sort, (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[14] = ulpinv;
result[15] = ulpinv;
if (*jtype != 22) {
io___23.ciunit = *nounit;
s_wsfe(&io___23);
do_fio(&c__1, "DGEESX3", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___24.ciunit = *nounit;
s_wsfe(&io___24);
do_fio(&c__1, "DGEESX3", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L130: */
}
/* L140: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
/* Compute both RCONDE and RCONDV without VS, and compare */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("N", sort, (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[14] = ulpinv;
result[15] = ulpinv;
if (*jtype != 22) {
io___27.ciunit = *nounit;
s_wsfe(&io___27);
do_fio(&c__1, "DGEESX4", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___28.ciunit = *nounit;
s_wsfe(&io___28);
do_fio(&c__1, "DGEESX4", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform tests (14) and (15) */
if (rcnde1 != rconde) {
result[14] = ulpinv;
}
if (rcndv1 != rcondv) {
result[15] = ulpinv;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L150: */
}
/* L160: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
/* Compute RCONDE with VS, and compare */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("V", sort, (L_fp)dslect_, "E", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[14] = ulpinv;
if (*jtype != 22) {
io___29.ciunit = *nounit;
s_wsfe(&io___29);
do_fio(&c__1, "DGEESX5", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___30.ciunit = *nounit;
s_wsfe(&io___30);
do_fio(&c__1, "DGEESX5", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform test (14) */
if (rcnde1 != rconde) {
result[14] = ulpinv;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L170: */
}
/* L180: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
/* Compute RCONDE without VS, and compare */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("N", sort, (L_fp)dslect_, "E", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[14] = ulpinv;
if (*jtype != 22) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "DGEESX6", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "DGEESX6", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform test (14) */
if (rcnde1 != rconde) {
result[14] = ulpinv;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L190: */
}
/* L200: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
/* Compute RCONDV with VS, and compare */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("V", sort, (L_fp)dslect_, "V", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[15] = ulpinv;
if (*jtype != 22) {
io___33.ciunit = *nounit;
s_wsfe(&io___33);
do_fio(&c__1, "DGEESX7", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "DGEESX7", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform test (15) */
if (rcndv1 != rcondv) {
result[15] = ulpinv;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L210: */
}
/* L220: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
/* Compute RCONDV without VS, and compare */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("N", sort, (L_fp)dslect_, "V", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[15] = ulpinv;
if (*jtype != 22) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "DGEESX8", (ftnlen)7);
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 *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "DGEESX8", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L250;
}
/* Perform test (15) */
if (rcndv1 != rcondv) {
result[15] = ulpinv;
}
/* Perform tests (10), (11), (12), and (13) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
result[10] = ulpinv;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
result[11] = ulpinv;
}
if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
result[12] = ulpinv;
}
/* L230: */
}
/* L240: */
}
if (sdim != sdim1) {
result[13] = ulpinv;
}
}
L250:
/* If there are precomputed reciprocal condition numbers, compare */
/* computed values with them. */
if (*comp) {
/* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that */
/* the logical function DSLECT selects the eigenvalues specified */
/* by NSLCT and ISLCT. */
sslct_1.seldim = *n;
sslct_1.selopt = 1;
eps = max(ulp,5.9605e-8);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ipnt[i__ - 1] = i__;
sslct_1.selval[i__ - 1] = FALSE_;
sslct_1.selwr[i__ - 1] = wrtmp[i__];
sslct_1.selwi[i__ - 1] = witmp[i__];
/* L260: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
vrmin = wrtmp[i__];
vimin = witmp[i__];
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (wrtmp[j] < vrmin) {
kmin = j;
vrmin = wrtmp[j];
vimin = witmp[j];
}
/* L270: */
}
wrtmp[kmin] = wrtmp[i__];
witmp[kmin] = witmp[i__];
wrtmp[i__] = vrmin;
witmp[i__] = vimin;
itmp = ipnt[i__ - 1];
ipnt[i__ - 1] = ipnt[kmin - 1];
ipnt[kmin - 1] = itmp;
/* L280: */
}
i__1 = *nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
sslct_1.selval[ipnt[islct[i__] - 1] - 1] = TRUE_;
/* L290: */
}
/* Compute condition numbers */
dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
dgeesx_("N", "S", (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
&wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != *n + 2) {
result[16] = ulpinv;
result[17] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DGEESX9", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L300;
}
/* Compare condition number for average of selected eigenvalues */
/* taking its condition number into account */
anorm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
/* Computing MAX */
d__1 = (doublereal) (*n) * eps * anorm;
v = max(d__1,smlnum);
if (anorm == 0.) {
v = 1.;
}
if (v > rcondv) {
tol = 1.;
} else {
tol = v / rcondv;
}
if (v > *rcdvin) {
tolin = 1.;
} else {
tolin = v / *rcdvin;
}
/* Computing MAX */
d__1 = tol, d__2 = smlnum / eps;
tol = max(d__1,d__2);
/* Computing MAX */
d__1 = tolin, d__2 = smlnum / eps;
tolin = max(d__1,d__2);
if (eps * (*rcdein - tolin) > rconde + tol) {
result[16] = ulpinv;
} else if (*rcdein - tolin > rconde + tol) {
result[16] = (*rcdein - tolin) / (rconde + tol);
} else if (*rcdein + tolin < eps * (rconde - tol)) {
result[16] = ulpinv;
} else if (*rcdein + tolin < rconde - tol) {
result[16] = (rconde - tol) / (*rcdein + tolin);
} else {
result[16] = 1.;
}
/* Compare condition numbers for right invariant subspace */
/* taking its condition number into account */
if (v > rcondv * rconde) {
tol = rcondv;
} else {
tol = v / rconde;
}
if (v > *rcdvin * *rcdein) {
tolin = *rcdvin;
} else {
tolin = v / *rcdein;
}
/* Computing MAX */
d__1 = tol, d__2 = smlnum / eps;
tol = max(d__1,d__2);
/* Computing MAX */
d__1 = tolin, d__2 = smlnum / eps;
tolin = max(d__1,d__2);
if (eps * (*rcdvin - tolin) > rcondv + tol) {
result[17] = ulpinv;
} else if (*rcdvin - tolin > rcondv + tol) {
result[17] = (*rcdvin - tolin) / (rcondv + tol);
} else if (*rcdvin + tolin < eps * (rcondv - tol)) {
result[17] = ulpinv;
} else if (*rcdvin + tolin < rcondv - tol) {
result[17] = (rcondv - tol) / (*rcdvin + tolin);
} else {
result[17] = 1.;
}
L300:
;
}
return 0;
/* End of DGET24 */
} /* dget24_ */
/* Subroutine */ int dchkbb_(integer *nsizes, integer *mval, integer *nval,
integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
integer *nrhs, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *ab, integer *ldab,
doublereal *bd, doublereal *be, doublereal *q, integer *ldq,
doublereal *p, integer *ldp, doublereal *c__, integer *ldc,
doublereal *cc, doublereal *work, integer *lwork, 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 DCHKBB: \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;
extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, dbdt02_(integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
logical badmm, badnn;
integer imode, iinfo;
extern /* Subroutine */ int dort01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *);
doublereal anorm;
integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int dlahd2_(integer *, char *);
logical badnnb;
extern /* Subroutine */ int dgbbrd_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *);
integer idumma[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlatmr_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, char *, char *, doublereal *, integer *, doublereal
*, doublereal *, integer *, doublereal *, char *, integer *,
integer *, integer *, doublereal *, doublereal *, char *,
doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublereal *, integer
*, doublereal *, integer *), dlasum_(char
*, integer *, integer *, integer *);
doublereal amninv;
integer jwidth;
doublereal rtunfl, rtovfl, ulpinv;
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 (release 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKBB tests the reduction of a general real rectangular band */
/* matrix to bidiagonal form. */
/* DGBBRD factors a general band matrix A as Q B P* , where * means */
/* transpose, B is upper bidiagonal, and Q and P are orthogonal; */
/* DGBBRD 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, DCHKBB 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, */
/* DCHKBB 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, DCHKBB */
/* 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 DCHKBB 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 DGBBRD. */
/* BE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the bidiagonal matrix */
/* computed by DGBBRD. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
/* Used to hold the orthogonal matrix Q computed by DGBBRD. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q. It must be at least 1 */
/* and at least max( NN ). */
/* P (workspace) DOUBLE PRECISION array, dimension (LDP, max(NN)) */
/* Used to hold the orthogonal matrix P computed by DGBBRD. */
/* LDP (input) INTEGER */
/* The leading dimension of P. It must be at least 1 */
/* and at least max( NN ). */
/* C (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
/* Used to hold the matrix C updated by DGBBRD. */
/* LDC (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* CC (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
/* Used to hold a copy of the matrix C. */
/* 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 */
--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;
--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_("DCHKBB", &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:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
dlaset_("Full", ldab, &n, &c_b18, &c_b18, &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) {
a[jcol + jcol * a_dim1] = anorm;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, singular values specified */
dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[m + 1], &iinfo);
} else if (itype == 6) {
/* Nonhermitian, singular values specified */
dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
work[m + 1], &iinfo);
} else if (itype == 9) {
/* Nonhermitian, random entries */
dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
c_b35, &c_b35, "T", "N", &work[n + 1], &c__1, &
c_b35, &work[(n << 1) + 1], &c__1, &c_b35, "N",
idumma, &kl, &ku, &c_b18, &anorm, "N", &a[
a_offset], lda, idumma, &iinfo);
} else {
iinfo = 1;
}
/* Generate Right-Hand Side */
dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b35, &c_b35, "T", "N", &work[m + 1], &c__1, &c_b35,
&work[(m << 1) + 1], &c__1, &c_b35, "N", idumma, &m,
nrhs, &c_b18, &c_b35, "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__) {
ab[ku + 1 + i__ - j + j * ab_dim1] = a[i__ + j *
a_dim1];
/* L100: */
}
/* L110: */
}
/* Copy C */
dlacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
ldc);
/* Call DGBBRD to compute B, Q and P, and to update C. */
dgbbrd_("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], &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DGBBRD", (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 */
dbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &p[p_offset], ldp, &work[1], &result[1]
);
dort01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
&result[2]);
dort01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
result[3]);
dbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
q[q_offset], ldq, &work[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, "DBB");
}
++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_("DBB", nounit, &nerrs, &ntestt);
return 0;
/* End of DCHKBB */
} /* dchkbb_ */
