/* Subroutine */ int zrqt03_(integer *m, integer *n, integer *k,
doublecomplex *af, doublecomplex *c__, doublecomplex *cc,
doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j, mc, nc;
doublereal eps;
char side[1];
integer info, iside;
extern logical lsame_(char *, char *);
doublereal resid;
integer minmn;
doublereal cnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char trans[1];
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
integer itrans;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlarnv_(
integer *, integer *, integer *, doublecomplex *), zungrq_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), zunmrq_(
char *, char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* ZRQT03 compares the results of a call to ZUNMRQ with the results of */
/* forming Q explicitly by a call to ZUNGRQ and then performing matrix */
/* multiplication by a call to ZGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows or columns of the matrix C; C is n-by-m if */
/* Q is applied from the left, or m-by-n if Q is applied from */
/* the right. M >= 0. */
/* N (input) INTEGER */
/* The order of the orthogonal matrix Q. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. N >= K >= 0. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the RQ factorization of an m-by-n matrix, as */
/* returned by ZGERQF. See CGERQF for further details. */
/* C (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* CC (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK must be at least M, and should be */
/* M*NB, where NB is the blocksize for this environment. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The test ratios compare two techniques for multiplying a */
/* random matrix C by an n-by-n orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = dlamch_("Epsilon");
minmn = min(*m,*n);
/* Quick return if possible */
if (minmn == 0) {
result[1] = 0.;
result[2] = 0.;
result[3] = 0.;
result[4] = 0.;
return 0;
}
/* Copy the last k rows of the factorization to the array Q */
zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k > 0 && *n > *k) {
i__1 = *n - *k;
zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)6, (ftnlen)6);
zungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
&info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.) {
cnorm = 1.;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
/* Copy C */
zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)6, (ftnlen)6);
if (*k > 0) {
zunmrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
1], lwork, &info);
}
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
n) * cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of ZRQT03 */
} /* zrqt03_ */
/* Subroutine */ int ddrvsp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *ainv, doublereal *b,
doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char 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[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;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
extern /* Subroutine */ int dppt02_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *), dspt01_(char *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal anorm;
extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer iuplo, izero, i1, i2, k1, lwork, nerrs;
extern /* Subroutine */ int dspsv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(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, nt;
static doublereal rcondc;
static char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
static doublereal ainvnm;
extern /* Subroutine */ int dsptrf_(char *, integer *, doublereal *,
integer *, integer *), dsptri_(char *, integer *,
doublereal *, integer *, doublereal *, integer *),
derrvx_(char *, integer *);
static doublereal result[6];
extern /* Subroutine */ int dspsvx_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
static integer lda, npp;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 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
=======
DDRVSP tests the driver routines DSPSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) DOUBLE PRECISION array, dimension
(NMAX*(NMAX+1)/2)
AFAC (workspace) DOUBLE PRECISION array, dimension
(NMAX*(NMAX+1)/2)
AINV (workspace) DOUBLE PRECISION array, dimension
(NMAX*(NMAX+1)/2)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(2,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;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
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: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
derrvx_(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);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 10;
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';
}
/* Set up parameters with DLATB4 and generate a test matrix
with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of the
matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L60: */
}
ioff += 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__) {
a[ioff + i__] = 0.;
/* L80: */
}
ioff = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
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 DSPSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
/* Factor the matrix A. */
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Compute inv(A) and take its norm. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
dsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
info);
ainvnm = dlansp_("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, "DLARHS", (ftnlen)6, (ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test DSPSV --- */
if (ifact == 2) {
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using DSPSV. */
s_copy(srnamc_1.srnamt, "DSPSV ", (ftnlen)6, (ftnlen)
6);
dspsv_(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 DSPSV . */
if (info != k) {
alaerh_(path, "DSPSV ", &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. */
dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
, &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "DSPSV ", (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 DSPSVX --- */
if (ifact == 2 && npp > 0) {
dlaset_("Full", &npp, &c__1, &c_b59, &c_b59, &afac[1],
&npp);
}
dlaset_("Full", &n, nrhs, &c_b59, &c_b59, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using DSPSVX. */
s_copy(srnamc_1.srnamt, "DSPSVX", (ftnlen)6, (ftnlen)6);
dspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
&b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 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 DSPSVX. */
if (info != k) {
/* 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, "DSPSVX", &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. */
dspt01_(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. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[(*nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
dppt05_(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 DSPSVX 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___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "DSPSVX", (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 DDRVSP */
} /* ddrvsp_ */
/* DECK XERSVE */
/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer
*kflag, integer *nerr, integer *level, integer *icount, ftnlen
librar_len, ftnlen subrou_len, ftnlen messg_len)
{
/* Initialized data */
static integer kountx = 0;
static integer nmsg = 0;
/* Format strings */
static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002"
" LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 "
" LEVEL COUNT\002)";
static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)";
static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED "
"= \002,i10)";
static char fmt_9030[] = "(1x)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__;
char lib[8], mes[20], sub[8];
integer lun[5], iunit, kunit, nunit;
static integer kount[10];
extern integer i1mach_(integer *);
static char libtab[8*10], mestab[20*10];
static integer nertab[10], levtab[10];
static char subtab[8*10];
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9000, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9010, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9020, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9030, 0 };
/* ***BEGIN PROLOGUE XERSVE */
/* ***SUBSIDIARY */
/* ***PURPOSE Record that an error has occurred. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3 */
/* ***TYPE ALL (XERSVE-A) */
/* ***KEYWORDS ERROR, XERROR */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */
/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */
/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */
/* *Arguments: */
/* LIBRAR :IN is the library that the message is from. */
/* SUBROU :IN is the subroutine that the message is from. */
/* MESSG :IN is the message to be saved. */
/* KFLAG :IN indicates the action to be performed. */
/* when KFLAG > 0, the message in MESSG is saved. */
/* when KFLAG=0 the tables will be dumped and */
/* cleared. */
/* when KFLAG < 0, the tables will be dumped and */
/* not cleared. */
/* NERR :IN is the error number. */
/* LEVEL :IN is the error severity. */
/* ICOUNT :OUT the number of times this message has been seen, */
/* or zero if the table has overflowed and does not */
/* contain this message specifically. When KFLAG=0, */
/* ICOUNT will not be altered. */
/* *Description: */
/* Record that this error occurred and possibly dump and clear the */
/* tables. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED I1MACH, XGETUA */
/* ***REVISION HISTORY (YYMMDD) */
/* 800319 DATE WRITTEN */
/* 861211 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900413 Routine modified to remove reference to KFLAG. (WRB) */
/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */
/* sequence, use IF-THEN-ELSE, make number of saved entries */
/* easily changeable, changed routine name from XERSAV to */
/* XERSVE. (RWC) */
/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERSVE */
/* ***FIRST EXECUTABLE STATEMENT XERSVE */
if (*kflag <= 0) {
/* Dump the table. */
if (nmsg == 0) {
return 0;
}
/* Print to each unit. */
xgetua_(lun, &nunit);
i__1 = nunit;
for (kunit = 1; kunit <= i__1; ++kunit) {
iunit = lun[kunit - 1];
if (iunit == 0) {
iunit = i1mach_(&c__4);
}
/* Print the table header. */
io___7.ciunit = iunit;
s_wsfe(&io___7);
e_wsfe();
/* Print body of table. */
i__2 = nmsg;
for (i__ = 1; i__ <= i__2; ++i__) {
io___9.ciunit = iunit;
s_wsfe(&io___9);
do_fio(&c__1, libtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, subtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20);
do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer)
);
e_wsfe();
/* L10: */
}
/* Print number of other errors. */
if (kountx != 0) {
io___16.ciunit = iunit;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer));
e_wsfe();
}
io___17.ciunit = iunit;
s_wsfe(&io___17);
e_wsfe();
/* L20: */
}
/* Clear the error tables. */
if (*kflag == 0) {
nmsg = 0;
kountx = 0;
}
} else {
/* PROCESS A MESSAGE... */
/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */
/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */
s_copy(lib, librar, (ftnlen)8, librar_len);
s_copy(sub, subrou, (ftnlen)8, subrou_len);
s_copy(mes, messg, (ftnlen)20, messg_len);
i__1 = nmsg;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(lib, libtab + ((i__ - 1) << 3), (ftnlen)8, (ftnlen)8) ==
0 && s_cmp(sub, subtab + ((i__ - 1) << 3), (ftnlen)8, (
ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, (
ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] &&
*level == levtab[i__ - 1]) {
++kount[i__ - 1];
*icount = kount[i__ - 1];
return 0;
}
/* L30: */
}
if (nmsg < 10) {
/* Empty slot found for new message. */
++nmsg;
s_copy(libtab + ((i__ - 1) << 3), lib, (ftnlen)8, (ftnlen)8);
s_copy(subtab + ((i__ - 1) << 3), sub, (ftnlen)8, (ftnlen)8);
s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20);
nertab[i__ - 1] = *nerr;
levtab[i__ - 1] = *level;
kount[i__ - 1] = 1;
*icount = 1;
} else {
/* Table is full. */
++kountx;
*icount = 0;
}
}
return 0;
/* Formats. */
} /* xersve_ */
/* Subroutine */ int sdrvrf2_(integer *nout, integer *nn, integer *nval, real
*a, integer *lda, real *arf, real *ap, real *asav)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "T";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
"nvertion\002,\002 routines ***\002)";
static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
"N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
"nes passed (\002,i5,\002 tests run)\002)";
static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
"ut of \002,i5,\002 error message recorded\002)";
/* System generated locals */
integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, n;
logical ok1, ok2;
integer iin, info;
char uplo[1];
integer nrun, iseed[4];
char cform[1];
integer iform;
logical lower;
integer iuplo, nerrs;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVRF2 tests the LAPACK RFP convertion routines. */
/* Arguments */
/* ========= */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* A (workspace) REAL array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
/* AP (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
/* A2 (workspace) REAL array, dimension (LDA,NMAX) */
/* ===================================================================== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
asav_dim1 = *lda;
asav_offset = 1 + asav_dim1;
asav -= asav_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--ap;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nerrs = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
i__1 = *nn;
for (iin = 1; iin <= i__1; ++iin) {
n = nval[iin];
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
lower = TRUE_;
if (iuplo == 1) {
lower = FALSE_;
}
/* Do first for CFORM = 'N', then for CFORM = 'T' */
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
++nrun;
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[i__ + j * a_dim1] = slarnd_(&c__2, iseed);
}
}
s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
strttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
s_copy(srnamc_1.srnamt, "DTFTTP", (ftnlen)32, (ftnlen)6);
stfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
s_copy(srnamc_1.srnamt, "DTPTTR", (ftnlen)32, (ftnlen)6);
stpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
ok1 = TRUE_;
if (lower) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = j; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok1 = FALSE_;
}
}
}
} else {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok1 = FALSE_;
}
}
}
}
++nrun;
s_copy(srnamc_1.srnamt, "DTRTTP", (ftnlen)32, (ftnlen)6);
strttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
;
s_copy(srnamc_1.srnamt, "DTPTTF", (ftnlen)32, (ftnlen)6);
stpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)6);
stfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
info);
ok2 = TRUE_;
if (lower) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = j; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok2 = FALSE_;
}
}
}
} else {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
if (a[i__ + j * a_dim1] != asav[i__ + j *
asav_dim1]) {
ok2 = FALSE_;
}
}
}
}
if (! ok1 || ! ok2) {
if (nerrs == 0) {
io___19.ciunit = *nout;
s_wsle(&io___19);
e_wsle();
io___20.ciunit = *nout;
s_wsfe(&io___20);
e_wsfe();
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
e_wsfe();
++nerrs;
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
if (nerrs == 0) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of SDRVRF2 */
} /* sdrvrf2_ */
/* Subroutine */ int sdrvpb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
real *s, real *work, real *rwork, integer *iwork, 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,a,\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,a,\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,a,\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 */
integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
ldab;
char fact[1];
integer ioff, mode, koff;
real amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact, kdval[4];
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *), spbt01_(char *, integer *,
integer *, real *, integer *, real *, integer *, real *, real *);
real anorm;
extern /* Subroutine */ int spbt02_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *), spbt05_(char *, integer *, integer *, integer *
, real *, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *);
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), spbsv_(char *, integer *, integer *, integer *, real *
, integer *, real *, integer *, integer *), sswap_(
integer *, real *, integer *, real *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
real rcondc;
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
logical nofact;
char packit[1];
integer iequed;
extern doublereal slansb_(char *, char *, integer *, integer *, real *,
integer *, real *);
real cndnum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), slaqsb_(char *, integer *, integer *, real
*, integer *, real *, real *, real *, char *);
real ainvnm;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *, integer *), slaset_(
char *, integer *, integer *, real *, real *, real *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
real *, real *, real *, integer *), spbtrf_(char *,
integer *, integer *, real *, integer *, integer *),
xlaenv_(integer *, integer *), slatms_(integer *, integer *, char
*, integer *, char *, real *, integer *, real *, real *, integer *
, integer *, char *, real *, integer *, real *, integer *), spbtrs_(char *, integer *, integer *, integer *,
real *, integer *, real *, integer *, integer *);
real result[6];
extern /* Subroutine */ int spbsvx_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, char *, real *,
real *, integer *, real *, integer *, real *, real *, real *,
real *, integer *, integer *), serrvx_(
char *, integer *);
/* 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.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVPB tests the driver routines SPBSV 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) REAL */
/* 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) REAL array, dimension (NMAX*NMAX) */
/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
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) {
serrvx_(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 SLATB4 and generate a test */
/* matrix with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)
6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &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;
scopy_(&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);
scopy_(&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);
scopy_(&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;
scopy_(&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__) {
work[iw + i__] = 0.f;
/* 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;
sswap_(&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);
sswap_(&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);
sswap_(&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;
sswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
slacpy_("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.f;
} else if (! lsame_(fact, "N")) {
/* Compute the condition number for comparison */
/* with the value returned by SPBSVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__5 = kd + 1;
slacpy_("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. */
spbequ_(uplo, &n, &kd, &afac[1], &ldab, &
s[1], &scond, &amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
slaqsb_(uplo, &n, &kd, &afac[1], &
ldab, &s[1], &scond, &amax,
equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in SGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = slansb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
spbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
slaset_("Full", &n, &n, &c_b45, &c_b46, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32,
(ftnlen)6);
spbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = slange_("1", &n, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
i__5 = kd + 1;
slacpy_("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, "SLARHS", (ftnlen)32, (
ftnlen)6);
slarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
&lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
lda);
if (nofact) {
/* --- Test SPBSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
i__5 = kd + 1;
slacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "SPBSV ", (ftnlen)32,
(ftnlen)6);
spbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from SPBSV . */
if (info != izero) {
alaerh_(path, "SPBSV ", &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. */
spbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
spbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&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, "SPBSV ", (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(real));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
L40:
;
}
/* --- Test SPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
slaset_("Full", &i__5, &n, &c_b45, &c_b45, &
afac[1], &ldab);
}
slaset_("Full", &n, nrhs, &c_b45, &c_b45, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y' */
slaqsb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using SPBSVX. */
s_copy(srnamc_1.srnamt, "SPBSVX", (ftnlen)32, (
ftnlen)6);
spbsvx_(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], &iwork[1], &info);
/* Check the error code from SPBSVX. */
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, "SPBSVX", &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. */
spbt01_(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. */
slacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
spbt02_(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")) {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &rcondc, &result[2]);
} else {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
spbt05_(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 SPBSVX with the computed */
/* value in RCONDC. */
result[5] = sget06_(&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, "SPBSVX", (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(real));
e_wsfe();
} else {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "SPBSVX", (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(real));
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 SDRVPB */
} /* sdrvpb_ */
/* Subroutine */ int zlqt01_(integer *m, integer *n, doublecomplex *a,
doublecomplex *af, doublecomplex *q, doublecomplex *l, integer *lda,
doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT01 tests ZGELQF, which computes the LQ factorization of an m-by-n */
/* matrix A, and partially tests ZUNGLQ which forms the n-by-n */
/* orthogonal matrix Q. */
/* ZLQT01 compares L with A*Q', and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The n-by-n orthogonal matrix Q. */
/* L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGELQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
zgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*n > 1) {
i__1 = *n - 1;
zlacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
1) + 1], lda);
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
zunglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
zlaset_("Full", m, n, &c_b10, &c_b10, &l[l_offset], lda);
zlacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L - A*Q' */
zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b15, &a[
a_offset], lda, &q[q_offset], lda, &c_b16, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
zherk_("Upper", "No transpose", n, n, &c_b24, &q[q_offset], lda, &c_b25, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT01 */
} /* zlqt01_ */
/* Subroutine */ int cerrps_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
complex a[16] /* was [4][4] */;
integer i__, j, piv[4], info;
real rwork[8];
extern /* Subroutine */ int cpstf2_(char *, integer *, complex *, integer
*, integer *, integer *, real *, real *, integer *),
alaesm_(char *, logical *, integer *), chkxer_(char *,
integer *, integer *, logical *, logical *), cpstrf_(char
*, integer *, complex *, integer *, integer *, integer *, real *,
real *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRPS tests the error exits for the COMPLEX routines */
/* for CPSTRF.. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
r__1 = 1.f / (real) (i__ + j);
a[i__1].r = r__1, a[i__1].i = 0.f;
/* L100: */
}
piv[j - 1] = j;
rwork[j - 1] = 0.f;
rwork[j + 3] = 0.f;
/* L110: */
}
infoc_1.ok = TRUE_;
/* Test error exits of the routines that use the Cholesky */
/* decomposition of an Hermitian positive semidefinite matrix. */
/* CPSTRF */
s_copy(srnamc_1.srnamt, "CPSTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPSTF2 */
s_copy(srnamc_1.srnamt, "CPSTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRPS */
} /* cerrps_ */
/* Subroutine */ int cchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
*thresh, complex *a, integer *lda, real *bd, real *be, real *s1, real
*s2, complex *x, integer *ldx, complex *y, complex *z__, complex *q,
integer *ldq, complex *pt, integer *ldpt, complex *u, complex *vt,
complex *work, integer *lwork, real *rwork, 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 CCHKBD: \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;
real r__1, r__2, r__3, r__4, r__5, r__6, r__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;
real ulp, cond;
integer jcol;
char path[3];
integer mmax, nmax;
real unfl, ovfl;
char uplo[1];
real temp1, temp2;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *), cbdt02_(integer
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, complex *, real *, real *), cbdt03_(char *, integer
*, integer *, real *, real *, complex *, integer *, real *,
complex *, integer *, complex *, real *);
logical badmm, badnn;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
integer nfail, imode;
real dumma[1];
integer iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
real anorm;
integer mnmin, mnmax, jsize, itype, jtype, iwork[1], ntest;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slahd2_(integer *, char *);
integer log2ui;
logical bidiag;
extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
integer *, real *, real *, complex *, complex *, complex *,
integer *, integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int cbdsqr_(char *, integer *, integer *, integer
*, integer *, real *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *),
cungbr_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
real amninv;
extern /* Subroutine */ int ssvdch_(integer *, real *, real *, real *,
real *, integer *);
integer minwrk;
real rtunfl, rtovfl, ulpinv, result[14];
integer mtypes;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 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___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 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 */
/* ======= */
/* CCHKBD checks the singular value decomposition (SVD) routines. */
/* CGEBRD reduces a complex general m by n matrix A to real upper or */
/* lower bidiagonal form 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. */
/* CUNGBR generates the orthogonal matrices Q and P' from CGEBRD. */
/* Note that Q and P are not necessarily square. */
/* CBDSQR 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, CBDSQR has an option to apply the left orthogonal matrix */
/* U to a matrix X, useful in least squares applications. */
/* 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 CGEBRD and CUNGBR */
/* (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 CBDSQR 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) 0 if the true singular values of B are within THRESH of */
/* those in S1. 2*THRESH if they are not. (Tested using */
/* SSVDCH) */
/* (10) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* Test CBDSQR 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 ) */
/* 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) CGEBRD 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, CCHKBD */
/* 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 CBDSQR. 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 CCHKBD to continue the same random */
/* number sequence. */
/* THRESH (input) REAL */
/* 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) COMPLEX 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) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* BE (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S1 (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S2 (workspace) REAL array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* X (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* LDX (input) INTEGER */
/* The leading dimension of the arrays X, Y, and Z. */
/* LDX >= max(1,MMAX). */
/* Y (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* Z (workspace) COMPLEX array, dimension (LDX,NRHS) */
/* Q (workspace) COMPLEX array, dimension (LDQ,MMAX) */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
/* PT (workspace) COMPLEX 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) COMPLEX array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* V (workspace) COMPLEX array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* WORK (workspace) COMPLEX 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)) */
/* RWORK (workspace) REAL array, dimension */
/* (5*max(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: LDP < 1 or LDP < MNMAX. */
/* -27: LWORK too small. */
/* If CLATMR, CLATMS, CGEBRD, CUNGBR, or CBDSQR, */
/* 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;
--rwork;
/* 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_("CCHKBD", &i__1);
return 0;
}
/* Initialize constants */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
nfail = 0;
ntest = 0;
unfl = slamch_("Safe minimum");
ovfl = slamch_("Overflow");
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
log2ui = (integer) (log(ulpinv) / log(2.f));
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.f / 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 L170;
}
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.f;
/* 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.f;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &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) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &rwork[1], &
imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &rwork[1], &
imode, &cond, &anorm, &m, &n, "N", &a[a_offset], lda,
&work[1], &iinfo);
} else if (itype == 6) {
/* Nonsymmetric, singular values specified */
clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &cond,
&anorm, &m, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N",
iwork, &c__0, &c__0, &c_b47, &anorm, "NO", &a[
a_offset], lda, iwork, &iinfo);
} else if (itype == 8) {
/* Symmetric, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N",
iwork, &m, &n, &c_b47, &anorm, "NO", &a[a_offset],
lda, iwork, &iinfo);
} else if (itype == 9) {
/* Nonsymmetric, random entries */
clatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
&c_b2, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
work[m + mnmin + 1], &c__1, &c_b37, "N", iwork, &m, &
n, &c_b47, &anorm, "NO", &a[a_offset], lda, iwork, &
iinfo);
} else if (itype == 10) {
/* Bidiagonal, random entries */
temp1 = log(ulp) * -2.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
bd[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
if (j < mnmin) {
be[j] = exp(temp1 * slarnd_(&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) {
clatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
c__6, &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &
c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
c_b37, "N", iwork, &mnmin, nrhs, &c_b47, &c_b37,
"NO", &y[y_offset], ldx, iwork, &iinfo);
} else {
clatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b37, &c_b2, "T", "N", &work[m + 1], &c__1, &
c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N",
iwork, &m, nrhs, &c_b47, &c_b37, "NO", &x[
x_offset], ldx, iwork, &iinfo);
}
}
/* Error Exit */
if (iinfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
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 CGEBRD and CUNGBR to compute B, Q, and P, do tests. */
if (! bidiag) {
/* Compute transformations to reduce A to bidiagonal form: */
/* B := Q' * A * P. */
clacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
i__3 = *lwork - (mnmin << 1);
cgebrd_(&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 CGEBRD. */
if (iinfo != 0) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "CGEBRD", (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;
}
clacpy_(" ", &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);
cungbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "CUNGBR(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);
cungbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "CUNGBR(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. */
cgemm_("Conjugate transpose", "No transpose", &m, nrhs, &m, &
c_b2, &q[q_offset], ldq, &x[x_offset], ldx, &c_b1, &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 */
cbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], &rwork[
1], result);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[1]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[2]);
}
/* Use CBDSQR to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT, and compute Z = U' * Y. */
scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
clacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &u[u_offset], ldpt);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &vt[vt_offset],
ldpt);
cbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &rwork[1], &
vt[vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset],
ldx, &rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "CBDSQR(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 L150;
}
}
/* Use CBDSQR to compute only the singular values of the */
/* bidiagonal matrix B; U, VT, and Z should not be modified. */
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &rwork[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CBDSQR(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 L150;
}
}
/* 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 */
cbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
cbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
u_offset], ldpt, &work[1], &rwork[1], &result[4]);
cunt01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &rwork[1], &result[5]);
cunt01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[6]);
/* Test 8: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[7] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[7] = ulpinv;
}
if (s1[i__] < 0.f) {
result[7] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.f) {
result[7] = ulpinv;
}
}
/* Test 9: Compare CBDSQR with and without singular vectors */
temp2 = 0.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
r__6 = (r__1 = s1[j], dabs(r__1)), r__7 = (r__2 = s2[j], dabs(
r__2));
r__4 = sqrt(unfl) * dmax(s1[1],1.f), r__5 = ulp * dmax(r__6,
r__7);
temp1 = (r__3 = s1[j] - s2[j], dabs(r__3)) / dmax(r__4,r__5);
temp2 = dmax(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 * (.5f - ulp);
i__3 = log2ui;
for (j = 0; j <= i__3; ++j) {
ssvdch_(&mnmin, &bd[1], &be[1], &s1[1], &temp1, &iinfo);
if (iinfo == 0) {
goto L140;
}
temp1 *= 2.f;
/* L130: */
}
L140:
result[9] = temp1;
/* Use CBDSQR to form the decomposition A := (QU) S (VT PT) */
/* from the bidiagonal form A := Q B PT. */
if (! bidiag) {
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &rwork[1], &pt[
pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
ldx, &rwork[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 */
cbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &rwork[
1], &result[10]);
cbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
q_offset], ldq, &work[1], &rwork[1], &result[11]);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[12]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[13]);
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= *thresh) {
if (nfail == 0) {
slahd2_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
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(real)
);
e_wsfe();
++nfail;
}
/* L160: */
}
if (! bidiag) {
ntest += 14;
} else {
ntest += 5;
}
L170:
;
}
/* L180: */
}
/* Summary */
alasum_(path, nout, &nfail, &ntest, &c__0);
return 0;
/* End of CCHKBD */
} /* cchkbd_ */
/* Subroutine */ int cchkqr_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
complex *a, complex *af, complex *aq, complex *ar, complex *ac,
complex *b, complex *x, complex *xact, complex *tau, complex *work,
real *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;
/* 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];
real anorm;
integer minmn, nerrs, lwork;
real cndnum;
real 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 */
/* ======= */
/* CCHKQR tests CGEQRF, CUNGQR and CUNMQR. */
/* 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) REAL */
/* 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 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AR (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* TAU (workspace) COMPLEX array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* RWORK (workspace) REAL array, dimension (NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Fuinctions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--ar;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QR", (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) {
cerrqr_(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 CLATB4 and generate a test matrix */
/* with CLATMS. */
clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &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 CQRT01; other values are */
/* used in the calls of CQRT02, 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.f;
}
nt = 2;
if (ik == 1) {
/* Test CGEQRF */
cqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
if (! cgennd_(&m, &n, &af[1], &lda)) {
result[7] = *thresh * 2;
}
++nt;
} else if (m >= n) {
/* Test CUNGQR, using factorization */
/* returned by CQRT01 */
cqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
}
if (m >= k) {
/* Test CUNMQR, using factorization returned */
/* by CQRT01 */
cqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call CGEQRS 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, "CLARHS", (ftnlen)32,
(ftnlen)6);
clarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
clacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "CGEQRS", (ftnlen)32,
(ftnlen)6);
cgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from CGEQRS. */
if (info != 0) {
alaerh_(path, "CGEQRS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
cget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[1], &lda, &b[1], &lda, &rwork[
1], &result[6]);
++nt;
}
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (i__ = 1; i__ <= 8; ++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(real));
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 CCHKQR */
} /* cchkqr_ */
/* $Procedure REMSUB ( Remove a substring ) */
/* Subroutine */ int remsub_(char *in, integer *left, integer *right, char *
out, ftnlen in_len, ftnlen out_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, j, l, r__;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer inlen;
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
integer outlen;
extern logical return_(void);
/* $ Abstract */
/* Remove the substring (LEFT:RIGHT) from a character string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASSIGNMENT, CHARACTER, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* LEFT I Position of first character to be removed. */
/* RIGHT I Position of last character to be removed. */
/* OUT O Output string. */
/* $ Detailed_Input */
/* IN is an input character string, from which a substring */
/* is to be removed. */
/* LEFT, */
/* RIGHT are the ends of the substring to be removed. */
/* $ Detailed_Output */
/* OUT is the output string. This is equivalent to the */
/* string that would be created by the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* If the string is too long to fit into OUT, it is */
/* truncated on the right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* Move the characters, beginning with RIGHT, one at a time to the */
/* positions immediately following LEFT. This has the same effect */
/* as the concatenation */
/* OUT = IN(1 : LEFT-1) // IN(RIGHT+1 : ) */
/* Because this operation is not standard for strings of length (*), */
/* this routine does not use concatenation. */
/* $ Examples */
/* The following examples illustrate the use of REMSUB. */
/* IN LEFT RIGHT OUT */
/* ----------------- ---- ----- ------------------------ */
/* 'ABCDEFGHIJ' 3 5 'ABFGHIJ' */
/* 'The best rabbit' 5 8 'The rabbit' */
/* 'The other woman' 1 4 'other woman' */
/* 'An Apple a day' 2 2 'A apple a day' */
/* 'An Apple a day' 5 2 An error is signalled. */
/* 'An Apple a day' 0 0 An error is signalled. */
/* 'An Apple a day' -3 3 An error is signalled. */
/* Whenever an error has been signalled, the contents of OUT are */
/* unpredictable. */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* If LEFT > RIGHT, RIGHT < 1, LEFT < 1, RIGHT > LEN(IN), or */
/* LEFT > LEN(IN), the error SPICE(INVALIDINDEX) is signalled. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* remove a substring */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 5-JAN-1989 (HAN) */
/* Error handling was added to detect invalid character */
/* positions. If LEFT > RIGHT, RIGHT < 1, LEFT < 1, */
/* RIGHT > LEN(IN), or LEFT > LEN(IN), an error is signalled. */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REMSUB", (ftnlen)6);
}
/* If a character position is out of range, signal an error. */
if (*left > *right || *right < 1 || *left < 1 || *right > i_len(in,
in_len) || *left > i_len(in, in_len)) {
setmsg_("Left location was *. Right location was *.", (ftnlen)42);
errint_("*", left, (ftnlen)1);
errint_("*", right, (ftnlen)1);
sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
chkout_("REMSUB", (ftnlen)6);
return 0;
} else {
l = *left;
r__ = *right;
}
/* How much of the input string will we use? And how big is the */
/* output string? */
inlen = lastnb_(in, in_len);
outlen = i_len(out, out_len);
/* Copy the first part of the input string. (One character at a */
/* time, in case this is being done in place.) */
/* Computing MIN */
i__2 = l - 1;
i__1 = min(i__2,outlen);
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[i__ - 1];
}
/* Now move the rest of the string over. */
i__ = l;
j = r__ + 1;
while(i__ <= outlen && j <= inlen) {
*(unsigned char *)&out[i__ - 1] = *(unsigned char *)&in[j - 1];
++i__;
++j;
}
/* Pad with blanks, if necessary. */
if (i__ <= outlen) {
s_copy(out + (i__ - 1), " ", out_len - (i__ - 1), (ftnlen)1);
}
chkout_("REMSUB", (ftnlen)6);
return 0;
} /* remsub_ */
/* Subroutine */ int clqt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
static integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cunglq_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLQT01 tests CGELQF, which computes the LQ factorization of an m-by-n
matrix A, and partially tests CUNGLQ which forms the n-by-n
orthogonal matrix Q.
CLQT01 compares L with A*Q', and checks that Q is orthogonal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the LQ factorization of A, as returned by CGELQF.
See CGELQF for further details.
Q (output) COMPLEX array, dimension (LDA,N)
The n-by-n orthogonal matrix Q.
L (workspace) COMPLEX array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L.
LDA >= max(M,N).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by CGELQF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (max(M,N))
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGELQF", (ftnlen)6, (ftnlen)6);
cgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*n > 1) {
i__1 = *n - 1;
clacpy_("Upper", m, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)6, (ftnlen)6);
cunglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b10, &c_b10, &l[l_offset], lda);
clacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L - A*Q' */
cgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b15, &a[
a_offset], lda, &q[q_offset], lda, &c_b16, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
cherk_("Upper", "No transpose", n, n, &c_b24, &q[q_offset], lda, &c_b25, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = clansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of CLQT01 */
} /* clqt01_ */
integer ilaenv_(integer* ispec, char* name__, char* opts, integer* n1,
integer* n2, integer* n3, integer* n4) {
/* System generated locals */
integer ret_val;
/* Builtin functions */
/* Subroutine */ int s_copy(char*, char*, ftnlen, ftnlen);
integer s_cmp(char*, char*, ftnlen, ftnlen);
/* Local variables */
static integer i__;
static char c1[1], c2[2], c3[3], c4[2];
static integer ic, nb, iz, nx;
static logical cname;
static integer nbmin;
static logical sname;
extern integer ieeeck_(integer*, real*, real*);
static char subnam[6];
extern integer iparmq_(integer*, char*, char*, integer*, integer*,
integer*, integer*);
ftnlen name_len, opts_len;
name_len = strlen(name__);
opts_len = strlen(opts);
/* -- LAPACK auxiliary routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ILAENV is called from the LAPACK routines to choose problem-dependent */
/* parameters for the local environment. See ISPEC for a description of */
/* the parameters. */
/* ILAENV returns an INTEGER */
/* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */
/* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */
/* This version provides a set of parameters which should give good, */
/* but not optimal, performance on many of the currently available */
/* computers. Users are encouraged to modify this subroutine to set */
/* the tuning parameters for their particular machine using the option */
/* and problem size information in the arguments. */
/* This routine will not function correctly if it is converted to all */
/* lower case. Converting it to all upper case is allowed. */
/* Arguments */
/* ========= */
/* ISPEC (input) INTEGER */
/* Specifies the parameter to be returned as the value of */
/* ILAENV. */
/* = 1: the optimal blocksize; if this value is 1, an unblocked */
/* algorithm will give the best performance. */
/* = 2: the minimum block size for which the block routine */
/* should be used; if the usable block size is less than */
/* this value, an unblocked routine should be used. */
/* = 3: the crossover point (in a block routine, for N less */
/* than this value, an unblocked routine should be used) */
/* = 4: the number of shifts, used in the nonsymmetric */
/* eigenvalue routines (DEPRECATED) */
/* = 5: the minimum column dimension for blocking to be used; */
/* rectangular blocks must have dimension at least k by m, */
/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
/* = 6: the crossover point for the SVD (when reducing an m by n */
/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
/* this value, a QR factorization is used first to reduce */
/* the matrix to a triangular form.) */
/* = 7: the number of processors */
/* = 8: the crossover point for the multishift QR method */
/* for nonsymmetric eigenvalue problems (DEPRECATED) */
/* = 9: maximum size of the subproblems at the bottom of the */
/* computation tree in the divide-and-conquer algorithm */
/* (used by xGELSD and xGESDD) */
/* =10: ieee NaN arithmetic can be trusted not to trap */
/* =11: infinity arithmetic can be trusted not to trap */
/* 12 <= ISPEC <= 16: */
/* xHSEQR or one of its subroutines, */
/* see IPARMQ for detailed explanation */
/* NAME (input) CHARACTER*(*) */
/* The name of the calling subroutine, in either upper case or */
/* lower case. */
/* OPTS (input) CHARACTER*(*) */
/* The character options to the subroutine NAME, concatenated */
/* into a single character string. For example, UPLO = 'U', */
/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
/* be specified as OPTS = 'UTN'. */
/* N1 (input) INTEGER */
/* N2 (input) INTEGER */
/* N3 (input) INTEGER */
/* N4 (input) INTEGER */
/* Problem dimensions for the subroutine NAME; these may not all */
/* be required. */
/* Further Details */
/* =============== */
/* The following conventions have been used when calling ILAENV from the */
/* LAPACK routines: */
/* 1) OPTS is a concatenation of all of the character options to */
/* subroutine NAME, in the same order that they appear in the */
/* argument list for NAME, even if they are not used in determining */
/* the value of the parameter specified by ISPEC. */
/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
/* that they appear in the argument list for NAME. N1 is used */
/* first, N2 second, and so on, and unused problem dimensions are */
/* passed a value of -1. */
/* 3) The parameter value returned by ILAENV is checked for validity in */
/* the calling subroutine. For example, ILAENV is used to retrieve */
/* the optimal blocksize for STRTRI as follows: */
/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
switch (*ispec) {
case 1: goto L10;
case 2: goto L10;
case 3: goto L10;
case 4: goto L80;
case 5: goto L90;
case 6: goto L100;
case 7: goto L110;
case 8: goto L120;
case 9: goto L130;
case 10: goto L140;
case 11: goto L150;
case 12: goto L160;
case 13: goto L160;
case 14: goto L160;
case 15: goto L160;
case 16: goto L160;
}
/* Invalid value for ISPEC */
ret_val = -1;
return ret_val;
L10:
/* Convert NAME to upper case if the first character is lower case. */
ret_val = 1;
s_copy(subnam, name__, (ftnlen)6, name_len);
ic = *(unsigned char*)subnam;
iz = 'Z';
if (iz == 90 || iz == 122) {
/* ASCII character set */
if (ic >= 97 && ic <= 122) {
*(unsigned char*)subnam = (char)(ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char*)&subnam[i__ - 1];
if (ic >= 97 && ic <= 122) {
*(unsigned char*)&subnam[i__ - 1] = (char)(ic - 32);
}
/* L20: */
}
}
} else if (iz == 233 || iz == 169) {
/* EBCDIC character set */
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
ic <= 169) {
*(unsigned char*)subnam = (char)(ic + 64);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char*)&subnam[i__ - 1];
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
162 && ic <= 169) {
*(unsigned char*)&subnam[i__ - 1] = (char)(ic + 64);
}
/* L30: */
}
}
} else if (iz == 218 || iz == 250) {
/* Prime machines: ASCII+128 */
if (ic >= 225 && ic <= 250) {
*(unsigned char*)subnam = (char)(ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char*)&subnam[i__ - 1];
if (ic >= 225 && ic <= 250) {
*(unsigned char*)&subnam[i__ - 1] = (char)(ic - 32);
}
/* L40: */
}
}
}
*(unsigned char*)c1 = *(unsigned char*)subnam;
sname = *(unsigned char*)c1 == 'S' || *(unsigned char*)c1 == 'D';
cname = *(unsigned char*)c1 == 'C' || *(unsigned char*)c1 == 'Z';
if (!(cname || sname)) {
return ret_val;
}
s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
switch (*ispec) {
case 1: goto L50;
case 2: goto L60;
case 3: goto L70;
}
L50:
/* ISPEC = 1: block size */
/* In these examples, separate code is provided for setting NB for */
/* real and complex. We assume that NB will take the same value in */
/* single or double precision. */
nb = 1;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
"RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
== 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nb = 32;
} else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
} else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nb = 32;
} else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
nb = 64;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
} else if (*(unsigned char*)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
} else if (*(unsigned char*)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nb = 32;
}
}
} else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
nb = 1;
}
}
ret_val = nb;
return ret_val;
L60:
/* ISPEC = 2: minimum block size */
nbmin = 2;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nbmin = 8;
} else {
nbmin = 8;
}
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nbmin = 2;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nbmin = 2;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
} else if (*(unsigned char*)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
} else if (*(unsigned char*)c3 == 'M') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nbmin = 2;
}
}
}
ret_val = nbmin;
return ret_val;
L70:
/* ISPEC = 3: crossover point */
nx = 0;
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
}
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nx = 32;
}
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
nx = 32;
}
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nx = 128;
}
}
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
if (*(unsigned char*)c3 == 'G') {
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
nx = 128;
}
}
}
ret_val = nx;
return ret_val;
L80:
/* ISPEC = 4: number of shifts (used by xHSEQR) */
ret_val = 6;
return ret_val;
L90:
/* ISPEC = 5: minimum column dimension (not used) */
ret_val = 2;
return ret_val;
L100:
/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
ret_val = (integer)((real) min(*n1, *n2) * 1.6f);
return ret_val;
L110:
/* ISPEC = 7: number of processors (not used) */
ret_val = 1;
return ret_val;
L120:
/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
ret_val = 50;
return ret_val;
L130:
/* ISPEC = 9: maximum size of the subproblems at the bottom of the */
/* computation tree in the divide-and-conquer algorithm */
/* (used by xGELSD and xGESDD) */
ret_val = 25;
return ret_val;
L140:
/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
/* ILAENV = 0 */
ret_val = 1;
if (ret_val == 1) {
ret_val = ieeeck_(&c__0, &c_b163, &c_b164);
}
return ret_val;
L150:
/* ISPEC = 11: infinity arithmetic can be trusted not to trap */
/* ILAENV = 0 */
ret_val = 1;
if (ret_val == 1) {
ret_val = ieeeck_(&c__1, &c_b163, &c_b164);
}
return ret_val;
L160:
/* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */
ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4)
;
return ret_val;
/* End of ILAENV */
} /* ilaenv_ */
/* Subroutine */ int cchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, complex *af, complex *b, complex *x, complex *xact, complex *work,
real *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;
real r__1, r__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 */
static real cond;
static integer mode, koff, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char norm[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer m, n;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4];
static complex z__[3];
extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
complex *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *), cgtt02_(char *, integer *,
integer *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *);
static real rcond;
extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
static real anorm;
static integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static char trans[1];
static integer izero, nerrs;
static logical zerot;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, 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;
extern /* Subroutine */ int cerrge_(char *, integer *);
static real rcondc;
extern doublereal clangt_(char *, integer *, complex *, complex *,
complex *);
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *), clacpy_(char *, integer *, integer
*, complex *, integer *, complex *, integer *), csscal_(
integer *, real *, complex *, integer *), cgtcon_(char *, integer
*, complex *, complex *, complex *, complex *, integer *, real *,
real *, complex *, integer *);
static real rcondi;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
static real rcondo;
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cgtrfs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, complex *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, complex *, real *, integer *), cgttrf_(integer *,
complex *, complex *, complex *, complex *, integer *, integer *);
static logical trfcon;
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
static real result[7];
static integer lda;
/* 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.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CCHKGT tests CGTTRF, -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) REAL
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 array, dimension (NMAX*4)
AF (workspace) COMPLEX array, dimension (NMAX*4)
B (workspace) COMPLEX array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) COMPLEX array, dimension (NMAX*NSMAX)
XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) REAL array, dimension
(max(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;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Complex 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) {
cerrge_(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 CLATB4. */
clatb4_(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, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&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 CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
ccopy_(&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);
clarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
csscal_(&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.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2].r = a[1].r, z__[2].i = a[1].i;
a[1].r = 0.f, a[1].i = 0.f;
}
} 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.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
} 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.f, a[i__4].i = 0.f;
i__4 = n - 1 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
}
/* + TEST 1
Factor A as L*U and compute the ratio
norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)6, (ftnlen)6);
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from CGTTRF. */
if (info != izero) {
alaerh_(path, "CGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
cgtt01_(&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(real));
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 = clangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use CGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
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.f, x[i__5].i = 0.f;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_(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 */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.f;
}
/* + TEST 7
Estimate the reciprocal of the condition number of the
matrix. */
s_copy(srnamc_1.srnamt, "CGTCON", (ftnlen)6, (ftnlen)6);
cgtcon_(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 CGTCON. */
if (info != 0) {
alaerh_(path, "CGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&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(real));
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) {
clarnv_(&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. */
clagtm_(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. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)6, (ftnlen)6);
cgttrs_(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 CGTTRS. */
if (info != 0) {
alaerh_(path, "CGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cgtt02_(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. */
cget04_(&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, "CGTRFS", (ftnlen)6, (ftnlen)6);
cgtrfs_(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 CGTRFS. */
if (info != 0) {
alaerh_(path, "CGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cgtt05_(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(real));
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 CCHKGT */
} /* cchkgt_ */
/* $Procedure SYFETC ( Fetch the Nth symbol in the table ) */
/* Subroutine */ int syfetc_(integer *nth, char *tabsym, integer *tabptr,
char *tabval, char *name__, logical *found, ftnlen tabsym_len, ftnlen
tabval_len, ftnlen name_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer nsym;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen), chkout_(char *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Fetch the Nth symbol in a character symbol table. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SYMBOLS */
/* $ Keywords */
/* SYMBOLS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* NTH I Index of symbol to be fetched. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL I Components of the symbol table. */
/* NAME O Name of the NTH symbol in the symbol table. */
/* FOUND O True if the NTH symbol is in the symbol table, */
/* false if it is not. */
/* $ Detailed_Input */
/* NTH is the index of the symbol to be fetched. If the NTH */
/* symbol does not exist, FOUND is FALSE. */
/* TABSYM, */
/* TABPTR, */
/* TABVAL are the components of a character symbol table. */
/* The NTH symbol may or may not be in the symbol */
/* table. The symbol table is not modified by this */
/* subroutine. */
/* $ Detailed_Output */
/* NAME is the name of the NTH symbol in the symbol table. */
/* FOUND is true if the NTH symbol is in the symbol table. */
/* If the NTH symbol is not in the table, FOUND is false. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The contents of the symbol table are: */
/* BOHR --> HYDROGEN ATOM */
/* EINSTEIN --> SPECIAL RELATIVITY */
/* PHOTOELECTRIC EFFECT */
/* BROWNIAN MOTION */
/* FERMI --> NUCLEAR FISSION */
/* The calls, */
/* CALL SYFETC ( 2, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( 3, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( -1, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* CALL SYFETC ( 4, TABSYM, TABPTR, TABVAL, NAME, FOUND ) */
/* result in the values for NAME and FOUND: */
/* NAME FOUND */
/* ---------- ----- */
/* EINSTEIN TRUE */
/* FERMI TRUE */
/* FALSE */
/* FALSE */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (HAN) */
/* -& */
/* $ Index_Entries */
/* fetch the nth symbol in the table */
/* -& */
/* $ Revisions */
/* - Beta Version 1.1.0, 17-FEB-1989 (NJB) */
/* Declaration of the unused variable SUMAI removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SYFETC", (ftnlen)6);
}
/* How many symbols to start with? */
nsym = cardc_(tabsym, tabsym_len);
/* If the value of NTH is out of range, that's a problem. */
if (*nth < 1 || *nth > nsym) {
*found = FALSE_;
/* Otherwise, we can proceed without fear of error. Merely locate */
/* and return the appropriate component from the values table. */
} else {
*found = TRUE_;
s_copy(name__, tabsym + (*nth + 5) * tabsym_len, name_len, tabsym_len)
;
}
chkout_("SYFETC", (ftnlen)6);
return 0;
} /* syfetc_ */
/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPO tests DPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from DPOTRF. */
if (info != izero) {
alaerh_(path, "DPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
dpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from DPOTRI. */
if (info != 0) {
alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)
6);
dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from DPOTRS. */
if (info != 0) {
alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)
6);
dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &iwork[1], &info);
/* Check error code from DPORFS. */
if (info != 0) {
alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &iwork[1], &info);
/* Check error code from DPOCON. */
if (info != 0) {
alaerh_(path, "DPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPO */
} /* dchkpo_ */
/* Subroutine */ int sdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, real *a, integer *lda, real *h__, real *ht, real *wr,
real *wi, real *wrt, real *wit, real *wrtmp, real *witmp, real *vs,
integer *ldvs, real *vs1, real *result, real *work, integer *lwork,
integer *iwork, logical *bwork, 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_9991[] = "(\002 SDRVSX: \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 -- Real Schur Form Decomposition "
"Expert \002,\002Driver\002,/\002 Matrix types (see SDRVSX for de"
"tails):\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,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
" T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
"e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
"e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
"rt)\002,\002, 1/ulp otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
"lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
"T same no matter what else computed (sort),\002,\002 1/ulp othe"
"rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
"ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
"succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
"tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
" 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
"therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
"RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
"RCONDV),\002)";
static char fmt_9993[] = "(\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)";
static char fmt_9992[] = "(\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, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, n, iwk;
real ulp, cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
logical badnn;
integer nfail, imode, iinfo;
real conds;
extern /* Subroutine */ int sget24_(logical *, integer *, real *, integer
*, integer *, integer *, real *, integer *, real *, real *, real *
, real *, real *, real *, real *, real *, real *, integer *, real
*, real *, real *, integer *, integer *, real *, real *, integer *
, integer *, logical *, integer *);
real anorm;
integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *);
real rcdein;
char adumma[1*1];
extern doublereal slamch_(char *);
integer idumma[1], ioldsd[4];
real rcdvin;
extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
integer *, real *, real *, char *, char *, char *, char *, real *,
integer *, real *, integer *, integer *, real *, real *, integer
*, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slatmr_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, char *, char *,
real *, integer *, real *, real *, integer *, real *, char *,
integer *, integer *, integer *, real *, real *, char *, real *,
integer *, integer *, integer *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*), slatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, real *, integer *, real *, integer *);
real ulpinv;
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___48 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
/* expert driver SGEESX. */
/* SDRVSX 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 SDRVSX 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, 15 */
/* tests 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 */
/* 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 signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (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 orthogonal and */
/* T has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is orthogonal and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (12) A matrix of the form U' T U, where U is orthogonal and */
/* T has real or complex conjugate paired eigenvalues randomly */
/* chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired */
/* eigenvalues randomly chosen from ( ULP, 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 (-1,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 eigenvalue */
/* average and right invariant subspace. For these matrices, in */
/* addition to tests (1) to (15) we will compute the following two */
/* tests: */
/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal average eigenvalue condition number */
/* computed by SGEESX 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 SGEESX 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 */
/* ========= */
/* 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 SDRVSX to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* 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) REAL 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) REAL array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by SGEESX. */
/* HT (workspace) REAL array, dimension (LDA, max(NN)) */
/* Yet another copy of the test matrix A, modified by SGEESX. */
/* WR (workspace) REAL array, dimension (max(NN)) */
/* WI (workspace) REAL array, dimension (max(NN)) */
/* 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) REAL array, dimension (max(NN)) */
/* WIT (workspace) REAL array, dimension (max(NN)) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but those computed when SGEESX only computes a partial */
/* eigendecomposition, i.e. not Schur vectors */
/* WRTMP (workspace) REAL array, dimension (max(NN)) */
/* WITMP (workspace) REAL array, dimension (max(NN)) */
/* More temporary storage for eigenvalues. */
/* VS (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS holds the computed Schur vectors. */
/* LDVS (input) INTEGER */
/* Leading dimension of VS. Must be at least max(1,max(NN)). */
/* VS1 (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS1 holds another copy of the computed Schur vectors. */
/* RESULT (output) REAL 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) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(3*NN(j),2*NN(j)**2) for all j. */
/* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN)) */
/* INFO (output) INTEGER */
/* If 0, successful exit. */
/* <0, input parameter -INFO is incorrect */
/* >0, SLATMR, SLATMS, SLATME or SGET24 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. */
/* 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 .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--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;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 12;
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.f) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX */
/* Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / 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 L130;
}
/* 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.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
slaset_("Full", lda, &n, &c_b18, &c_b18, &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) {
a[jcol + jcol * a_dim1] = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
if (jcol > 1) {
a[jcol + (jcol - 1) * a_dim1] = 1.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[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.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
*(unsigned char *)&adumma[0] = ' ';
slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
3], lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
a_dim1 + 3], lda);
slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
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 <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else {
/* Computing MAX */
i__3 = n * 3, i__4 = (n << 1) * n;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
sget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, path, (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);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___46.ciunit = *nounit;
s_wsfe(&io___46);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
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(real)
);
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
jtype = 0;
L160:
io___48.ciunit = *niunit;
i__1 = s_rsle(&io___48);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
if (nslct > 0) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
real));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
e_rsle();
sget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
&wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
iwork[1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
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);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
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(real));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of SDRVSX */
} /* sdrvsx_ */
/* $Procedure INSRTC ( Insert an item into a character set ) */
/* Subroutine */ int insrtc_(char *item, char *a, ftnlen item_len, ftnlen
a_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer card, slen, last, size, i__;
extern integer cardc_(char *, ftnlen);
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizec_(char *, ftnlen);
logical in;
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen);
extern integer lstlec_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *,
ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Insert an item into a character set. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SETS */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I Item to be inserted. */
/* A I/O Insertion set. */
/* $ Detailed_Input */
/* ITEM is an item which is to be inserted into the */
/* specified set. ITEM may or may not already be an */
/* element of the set. If ITEM is longer than the */
/* length SLEN of the elements of A, only the substring */
/* consisting of the first SLEN characters of ITEM will */
/* be inserted into the set; any trailing non-blank */
/* characters in ITEM are ignored. */
/* A is a set. */
/* On input, A may or may not contain the input item */
/* as an element. */
/* $ Detailed_Output */
/* A on output contains the union of the input set and */
/* the singleton set containing the input item, unless */
/* there was not sufficient room in the set for the */
/* item to be included, in which case the set is not */
/* changed and an error is signaled. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the insertion of the item into the set causes an excess */
/* of elements, the error SPICE(SETEXCESS) is signaled. */
/* 2) If the item to be inserted has greater length than the string */
/* length of the elements of the set, the item will be truncated */
/* on the right when it is inserted. The insertion point of */
/* the element will be determined by the comparison of the */
/* truncated item to members of the set. If, after truncation, */
/* the item to be inserted matches an element already present */
/* in the set, no insertion occurs. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* In the following example, the element 'PLUTO' is removed from */
/* the character set PLANETS and inserted into the character set */
/* ASTEROIDS. */
/* CALL REMOVC ( 'PLUTO', PLANETS ) */
/* CALL INSRTC ( 'PLUTO', ASTEROIDS ) */
/* If 'PLUTO' is not an element of PLANETS, then the contents of */
/* PLANETS are not changed. Similarly, if 'PLUTO' is already an */
/* element of ASTEROIDS, the contents of ASTEROIDS remain unchanged. */
/* Because inserting an element into a set can increase the */
/* cardinality of the set, an error may occur in the insertion */
/* routines. */
/* $ Literature_References */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Bug fix: when the item to be inserted would, after */
/* truncation to the set's string length, match an item */
/* already in the set, no insertion is performed. Previously */
/* the truncated string was inserted, corrupting the set. */
/* Long error message was updated to include size of */
/* set into which insertion was attempted. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* insert an item into a character set */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 01-NOV-2005 (NJB) */
/* Bug fix: when the item to be inserted would, after */
/* truncation to the set's string length, match an item */
/* already in the set, no insertion is performed. Previously */
/* the truncated string was inserted, corrupting the set. */
/* Long error message was updated to include size of */
/* set into which insertion was attempted. */
/* - Beta Version 1.1.0, 06-JAN-1989 (NJB) */
/* Calling protocol of EXCESS changed. Call to SETMSG removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("INSRTC", (ftnlen)6);
/* What are the size and cardinality of the set? */
size = sizec_(a, a_len);
card = cardc_(a, a_len);
/* When we insert an item into the set, any trailing characters */
/* that don't fit are truncated. So in deciding where to insert */
/* the item, we ignore any characters that won't remain after */
/* insertion. */
/* We're going to consider only the initial substring of ITEM */
/* whose length doesn't exceed the string length of the set's */
/* members. */
/* Computing MIN */
i__1 = i_len(item, item_len), i__2 = i_len(a + a_len * 6, a_len);
slen = min(i__1,i__2);
/* Find the last element of the set which would come before the */
/* input item. This will be the item itself, if it is already an */
/* element of the set. */
last = lstlec_(item, &card, a + a_len * 6, slen, a_len);
/* Is the item already in the set? If not, it needs to be inserted. */
if (last > 0) {
in = s_cmp(a + (last + 5) * a_len, item, a_len, slen) == 0;
} else {
in = FALSE_;
}
if (! in) {
/* If there is room in the set for the new element, then move */
/* the succeeding elements back to make room. And update the */
/* cardinality for future reference. */
if (card < size) {
i__1 = last + 1;
for (i__ = card; i__ >= i__1; --i__) {
s_copy(a + (i__ + 6) * a_len, a + (i__ + 5) * a_len, a_len,
a_len);
}
s_copy(a + (last + 6) * a_len, item, a_len, slen);
i__1 = card + 1;
scardc_(&i__1, a, a_len);
} else {
setmsg_("An element could not be inserted into the set due to la"
"ck of space; set size is #.", (ftnlen)82);
errint_("#", &size, (ftnlen)1);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
}
chkout_("INSRTC", (ftnlen)6);
return 0;
} /* insrtc_ */
/* $Procedure EXPFNM_1 ( Expand a filename ) */
/* Subroutine */ int expfnm_1__(char *infil, char *outfil, ftnlen infil_len,
ftnlen outfil_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
integer need, keep;
char word[255];
integer blank;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen);
integer inlen, slash;
extern integer rtrim_(char *, ftnlen);
integer dirlen;
extern /* Subroutine */ int getenv_(char *, char *, ftnlen, ftnlen);
integer wrdlen;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
integer outlen;
extern logical return_(void);
char dir[255];
extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);
/* $ Abstract */
/* Given a filename, expand it to be a full filename. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* FILES */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INFIL I The filename to be expanded. */
/* OUTFIL O The expanded filename. */
/* $ Detailed_Input */
/* INFIL is the filename to be expanded. */
/* $ Detailed_Output */
/* OUTFIL is the expanded filename. If no expansion could be */
/* done, the value of OUTFIL is equal to the value of */
/* INFIL. OUTFIL may not overwrite INFIL. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the input filename is blank, begins with blank characters, */
/* or has embedded blanks in it, the error SPICE(BADFILENAME) */
/* is signalled. */
/* 2) If the expanded filename is too long to fit into the */
/* output string, the error SPICE(STRINGTOOSMALL) is signalled. */
/* 3) The output string may not overwrite the input string. */
/* 4) If no expansion of the input filename can be done, the */
/* output filename is assigned the value of the input filename. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The input filename may not be blank, begin with blank characters, */
/* nor may it it contain embedded blanks. As a general rule, */
/* SPICELIB routines do not allow blank characters as part of a */
/* filename. */
/* Unix platforms: */
/* On the Unix platforms, a filename containing an environment */
/* variable must be expanded completely before FORTRAN can do */
/* anything with it. FORTRAN interacts directly with the kernel, and */
/* as a result does not pass input filenames through the shell */
/* for expansion of environment variables. */
/* VAX/VMS, Alpha/OpenVMS platforms: */
/* The operating system does filname expansion itself, so this */
/* routine currently does not expand the name. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* Unix platforms: */
/* This routine cannot be used to expand a file name whose form */
/* is '~xxx', where xxx is an account name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - Beta Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - Beta Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - Beta Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - Beta Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - Beta Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - Beta Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - Beta Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - Beta Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - Beta Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - Beta Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - Beta Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - Beta Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - Beta Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - Beta Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - Beta Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - Beta Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - Beta Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - Beta Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - Beta Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - Beta Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - Beta Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - Beta Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are WIN-NT */
/* - Beta Version 3.0.3, 21-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - Beta Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - Beta Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - Beta Version 3.0.0, 05-APR-1998 (NJB) */
/* Added references to the PC-LINUX environment. */
/* - Beta Version 2.1.0, 5-JAN-1995 (HAN) */
/* Removed Sun Solaris environment since it is now the same */
/* as the Sun OS 4.1.x environment. */
/* Removed DEC Alpha/OpenVMS environment since it is now the */
/* same as the VAX environment. */
/* - Beta Version 2.0.0, 08-JUL-1994 (HAN) */
/* The capability of resolving a Unix filename that contains */
/* an environment variable directory specificiation plus a */
/* filename has been added. */
/* - Beta Version 1.0.0, 06-APR-1992 (HAN) */
/* -& */
/* $ Index_Entries */
/* expand a filename */
/* -& */
/* SPICELIB functions */
/* Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("EXPFNM_1", (ftnlen)8);
}
/* If the input filename is blank, that's an error. */
if (s_cmp(infil, " ", infil_len, (ftnlen)1) == 0) {
setmsg_("The input filename '#' was blank.", (ftnlen)33);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* If there are blanks anywhere in the filename, SPICELIB */
/* considers the filename to be invalid. */
blank = pos_(infil, " ", &c__1, rtrim_(infil, infil_len), (ftnlen)1);
if (blank != 0) {
setmsg_("The input filename '#' had blank characters in it.", (ftnlen)
50);
errch_("#", infil, (ftnlen)1, infil_len);
sigerr_("SPICE(BADFILENAME)", (ftnlen)18);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
}
/* Look for a slash in the filename. */
slash = pos_(infil, "/", &c__1, infil_len, (ftnlen)1);
/* If we found a slash in a position other than the first */
/* character position, we want to examine the word that */
/* comes before it just in case it is an environment */
/* variable. */
if (slash > 1) {
s_copy(word, infil, (ftnlen)255, slash - 1);
getenv_(word, dir, (ftnlen)255, (ftnlen)255);
/* If the word was an environment variable, then construct */
/* the expanded filename. If it wasn't, just return the original */
/* input filename. */
if (s_cmp(dir, " ", (ftnlen)255, (ftnlen)1) != 0) {
s_copy(outfil, infil, outfil_len, infil_len);
inlen = rtrim_(infil, infil_len);
wrdlen = rtrim_(word, (ftnlen)255);
dirlen = rtrim_(dir, (ftnlen)255);
outlen = i_len(outfil, outfil_len);
keep = inlen - wrdlen;
need = keep + dirlen;
/* If the output filename length is not long enough for */
/* the substitution, signal an error. Otherwise, substitute */
/* in the new value. */
if (need > outlen) {
setmsg_("The expanded filename for the input filename '#' ex"
"ceeded the length of the output filename. The expand"
"ed name was # characters too long.", (ftnlen)137);
errch_("#", infil, (ftnlen)1, infil_len);
i__1 = need - outlen;
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(STRINGTOOSMALL)", (ftnlen)21);
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} else {
i__1 = slash - 1;
repsub_(infil, &c__1, &i__1, dir, outfil, infil_len, rtrim_(
dir, (ftnlen)255), outfil_len);
}
} else {
s_copy(outfil, infil, outfil_len, infil_len);
}
} else {
/* No slashes are in the filename, so it's just an easy case. */
/* It's possible that the entire filename is an environment */
/* variable. If it's not, then just return the input filename. */
getenv_(infil, outfil, infil_len, outfil_len);
if (s_cmp(outfil, " ", outfil_len, (ftnlen)1) == 0) {
s_copy(outfil, infil, outfil_len, infil_len);
}
}
chkout_("EXPFNM_1", (ftnlen)8);
return 0;
} /* expfnm_1__ */
/* $Procedure UNIONC ( Union two character sets ) */
/* Subroutine */ int unionc_(char *a, char *b, char *c__, ftnlen a_len,
ftnlen b_len, ftnlen c_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
logical l_lt(char *, char *, ftnlen, ftnlen), l_gt(char *, char *, ftnlen,
ftnlen);
/* Local variables */
integer over, acard, bcard;
extern integer cardc_(char *, ftnlen);
integer ccard;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern integer sizec_(char *, ftnlen);
integer csize;
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen);
integer apoint, bpoint;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), excess_(integer *, char *, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Union two character sets to form a third set. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SETS */
/* $ Keywords */
/* CELLS, SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* A I First input set. */
/* B I Second input set. */
/* C O Union of A and B. */
/* $ Detailed_Input */
/* A is a set. */
/* B is a set, distinct from A. */
/* $ Detailed_Output */
/* C is a set, distinct from sets A and B, which */
/* contains the union of A and B (that is, all of */
/* the elements which are in A or B or both). */
/* If the size (maximum cardinality) of C is smaller */
/* than the cardinality of the union of A and B, */
/* then only as many items as will fit in C are */
/* included, and an error is signalled. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The UNION of two sets contains every element which is */
/* in the first set, or in the second set, or in both sets. */
/* {a,b} union {c,d} = {a,b,c,d} */
/* {a,b,c} {b,c,d} {a,b,c,d} */
/* {a,b,c,d} {} {a,b,c,d} */
/* {} {a,b,c,d} {a,b,c,d} */
/* {} {} {} */
/* The following call */
/* CALL UNIONC ( PLANETS, ASTEROIDS, RESULT ) */
/* places the union of the character sets PLANETS and */
/* ASTEROIDS into the character set RESULT. */
/* The output set must be distinct from both of the input sets. */
/* For example, the following calls are invalid. */
/* CALL UNIONI ( CURRENT, NEW, CURRENT ) */
/* CALL UNIONI ( NEW, CURRENT, CURRENT ) */
/* In each of the examples above, whether or not the subroutine */
/* signals an error, the results will almost certainly be wrong. */
/* Nearly the same effect can be achieved, however, by placing the */
/* result into a temporary set, which is immediately copied back */
/* into one of the input sets, as shown below. */
/* CALL UNIONI ( CURRENT, NEW, TEMP ) */
/* CALL COPYI ( TEMP, NEW ) */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* 1) If the union of the two sets causes an excess of elements, the */
/* error SPICE(SETEXCESS) is signalled. */
/* 2) If length of the elements of the output set is < the */
/* maximum of the lengths of the elements of the input */
/* sets, the error SPICE(ELEMENTSTOOSHORT) is signalled. */
/* $ Files */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* C.A. Curzon (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 18-JUN-1999 (WLT) */
/* Made CHKOUT calls consistent with CHKIN. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (CAC) (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* union two character sets */
/* -& */
/* $ Revisions */
/* - Beta Version 2.0.0, 05-JAN-1989 (NJB) */
/* Error signalled if output set elements are not long enough. */
/* Length must be at least max of lengths of input elements. */
/* Also, calling protocol for EXCESS has been changed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Set up the error processing. */
if (return_()) {
return 0;
}
chkin_("UNIONC", (ftnlen)6);
/* Make sure output set elements are long enough. */
/* Computing MAX */
i__1 = i_len(a, a_len), i__2 = i_len(b, b_len);
if (i_len(c__, c_len) < max(i__1,i__2)) {
setmsg_("Length of output cell is #. Length required to contain res"
"ult is #.", (ftnlen)68);
i__1 = i_len(c__, c_len);
errint_("#", &i__1, (ftnlen)1);
/* Computing MAX */
i__2 = i_len(a, a_len), i__3 = i_len(b, b_len);
i__1 = max(i__2,i__3);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(ELEMENTSTOOSHORT)", (ftnlen)23);
chkout_("UNIONC", (ftnlen)6);
return 0;
}
/* Find the cardinality of the input sets, and the allowed size */
/* of the output set. */
acard = cardc_(a, a_len);
bcard = cardc_(b, b_len);
csize = sizec_(c__, c_len);
/* Begin with the input pointers at the first elements of the */
/* input sets. The cardinality of the output set is zero. */
/* And there is no overflow so far. */
apoint = 1;
bpoint = 1;
ccard = 0;
over = 0;
/* When the ends of both input sets are reached, we're done. */
while(apoint <= acard || bpoint <= bcard) {
/* If there is still space in the output set, fill it */
/* as necessary. */
if (ccard < csize) {
if (apoint > acard) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len,
c_len, b_len);
++bpoint;
} else if (bpoint > bcard) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
} else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len) == 0) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
++bpoint;
} else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, a + (apoint + 5) * a_len,
c_len, a_len);
++apoint;
} else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++ccard;
s_copy(c__ + (ccard + 5) * c_len, b + (bpoint + 5) * b_len,
c_len, b_len);
++bpoint;
}
/* Otherwise, stop filling the array, but continue to count the */
/* number of elements in excess of the size of the output set. */
} else {
if (apoint > acard) {
++over;
++bpoint;
} else if (bpoint > bcard) {
++over;
++apoint;
} else if (s_cmp(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len) == 0) {
++over;
++apoint;
++bpoint;
} else if (l_lt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++over;
++apoint;
} else if (l_gt(a + (apoint + 5) * a_len, b + (bpoint + 5) *
b_len, a_len, b_len)) {
++over;
++bpoint;
}
}
}
/* Set the cardinality of the output set. */
scardc_(&ccard, c__, c_len);
/* Report any excess. */
if (over > 0) {
excess_(&over, "set", (ftnlen)3);
sigerr_("SPICE(SETEXCESS)", (ftnlen)16);
}
chkout_("UNIONC", (ftnlen)6);
return 0;
} /* unionc_ */
/* Subroutine */ int dchkge_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
"=\002,i4,\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,g1"
"2.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)"
;
/* 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 norm[1], type__[1];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n;
extern /* Subroutine */ int dget01_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *), dget02_(char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dget03_(integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *);
static doublereal rcond;
static integer nimat;
static doublereal anorm;
static integer itran;
static char trans[1];
static integer izero, nerrs;
static doublereal dummy;
static integer lwork;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer nb, im, in, kl;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
static doublereal rcondi;
extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
static doublereal ainvnm;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static logical trfcon;
static doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *);
static doublereal result[8];
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 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
=======
DCHKGE tests DGETRF, -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.
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.
NMAX (input) INTEGER
The maximum value permitted for M or N, used in dimensioning
the work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(2*NMAX,2*NSMAX+NWORK))
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (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) {
derrge_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
/* 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';
nimat = 11;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L100;
}
/* Set up parameters with DLATB4 and generate a test matrix
with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* 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 = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__4 = n - izero + 1;
dlaset_("Full", &m, &i__4, &c_b21, &c_b21, &a[ioff +
1], &lda);
}
} else {
izero = 0;
}
/* These lines, if used in place of the calls in the DO 60
loop, cause the code to bomb on a Sun SPARCstation.
ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK )
ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK )
Do for each blocksize in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the matrix. */
dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)6, (ftnlen)6);
dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
/* Check error code from DGETRF. */
if (info != izero) {
alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1
Reconstruct matrix from factors and compute residual. */
dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
rwork[1], result);
nt = 1;
/* + TEST 2
Form the inverse if the factorization was successful
and compute the residual. */
if (m == n && info == 0) {
dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)6, (ftnlen)
6);
nrhs = nsval[1];
lwork = *nmax * max(3,nrhs);
dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
lwork, &info);
/* Check error code from DGETRI. */
if (info != 0) {
alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
&c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
nout);
}
/* Compute the residual for the matrix times its
inverse. Also compute the 1-norm condition number
of A. */
dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondo, &result[1]);
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
/* Compute the infinity-norm condition number of A. */
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
nt = 2;
} else {
/* Do only the condition estimate if INFO > 0. */
trfcon = TRUE_;
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
rcondo = 0.;
rcondi = 0.;
}
/* Print information about the tests so far 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) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
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;
}
/* L30: */
}
nrun += nt;
/* Skip the remaining tests if this is not the first
block size or if M .ne. N. Skip the solve tests if
the matrix is singular. */
if (inb > 1 || m != n) {
goto L90;
}
if (trfcon) {
goto L70;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++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;
} else {
rcondc = rcondi;
}
/* + TEST 3
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
&nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)6, (
ftnlen)6);
dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
1], &x[1], &lda, &info);
/* Check error code from DGETRS. */
if (info != 0) {
alaerh_(path, "DGETRS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
2]);
/* + TEST 4
Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7
Use iterative refinement to improve the
solution. */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)6, (
ftnlen)6);
dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
lda, &iwork[1], &b[1], &lda, &x[1], &lda,
&rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[n + 1], &info);
/* Check error code from DGERFS. */
if (info != 0) {
alaerh_(path, "DGERFS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dget07_(trans, &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___46.ciunit = *nout;
s_wsfe(&io___46);
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;
}
/* L40: */
}
nrun += 5;
/* L50: */
}
/* L60: */
}
/* + TEST 8
Get an estimate of RCOND = 1/CNDNUM. */
L70:
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, "DGECON", (ftnlen)6, (ftnlen)
6);
dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
work[1], &iwork[n + 1], &info);
/* Check error code from DGECON. */
if (info != 0) {
alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
dummy = rcond;
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___50.ciunit = *nout;
s_wsfe(&io___50);
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__8, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L80: */
}
L90:
;
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKGE */
} /* dchkge_ */
/* $Procedure ZZSPKAP0 ( S/P Kernel, apparent state ) */
/* Subroutine */ int zzspkap0_(integer *targ, doublereal *et, char *ref,
doublereal *sobs, char *abcorr, doublereal *starg, doublereal *lt,
ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char flags[5*9] = "NONE " "LT " "LT+S " "CN " "CN+S " "XLT "
"XLT+S" "XCN " "XCN+S";
static char prvcor[5] = " ";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char corr[5];
extern /* Subroutine */ int zzspksb0_(integer *, doublereal *, char *,
doublereal *, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
char corr2[5];
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen), moved_(
doublereal *, integer *, doublereal *);
static logical usecn;
doublereal sapos[3];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
static logical uselt;
extern doublereal vnorm_(doublereal *), clight_(void);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int stelab_(doublereal *, doublereal *,
doublereal *), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
stlabx_(doublereal *, doublereal *, doublereal *);
integer ltsign;
extern /* Subroutine */ int setmsg_(char *, ftnlen), irfnum_(char *,
integer *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time and */
/* stellar aberration. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of observer's state. */
/* SOBS I State of observer wrt. solar system barycenter. */
/* ABCORR I Aberration correction flag. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past J2000 */
/* TDB, at which the state of the target body relative to */
/* the observer is to be computed. ET refers to time at */
/* the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the observer's state SOBS is expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string REF. */
/* SOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* SOBS is a 6-vector: the first three components of */
/* SOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. SOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the Particulars section for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* The 'CN' correction typically does not */
/* substantially improve accuracy because */
/* the errors made by ignoring */
/* relativistic effects may be larger than */
/* the improvement afforded by obtaining */
/* convergence of the light time solution. */
/* The 'CN' correction computation also */
/* requires a significantly greater number */
/* of CPU cycles than does the */
/* one-iteration light time correction. */
/* 'CN+S' Converged Newtonian light time */
/* and stellar aberration corrections. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time and stellar */
/* aberration corrections. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* The velocity component of STARG is obtained by */
/* evaluating the target's geometric state at the light */
/* time corrected epoch, so for aberration-corrected */
/* states, the velocity is not precisely equal to the */
/* time derivative of the position. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for aberrations, then LT is the one-way light time */
/* between the observer and the light time corrected */
/* target location. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* 'SPICE(SPKINVALIDOPTION)' is signaled. */
/* 2) If the reference frame requested is not a recognized */
/* inertial reference frame, the error 'SPICE(BADFRAME)' */
/* is signaled. */
/* 3) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* In space science or engineering applications one frequently */
/* wishes to know where to point a remote sensing instrument, such */
/* as an optical camera or radio antenna, in order to observe or */
/* otherwise receive radiation from a target. This pointing problem */
/* is complicated by the finite speed of light: one needs to point */
/* to where the target appears to be as opposed to where it actually */
/* is at the epoch of observation. We use the adjectives */
/* "geometric," "uncorrected," or "true" to refer to an actual */
/* position or state of a target at a specified epoch. When a */
/* geometric position or state vector is modified to reflect how it */
/* appears to an observer, we describe that vector by any of the */
/* terms "apparent," "corrected," "aberration corrected," or "light */
/* time and stellar aberration corrected." */
/* The SPICE Toolkit can correct for two phenomena affecting the */
/* apparent location of an object: one-way light time (also called */
/* "planetary aberration") and stellar aberration. Correcting for */
/* one-way light time is done by computing, given an observer and */
/* observation epoch, where a target was when the observed photons */
/* departed the target's location. The vector from the observer to */
/* this computed target location is called a "light time corrected" */
/* vector. The light time correction depends on the motion of the */
/* target, but it is independent of the velocity of the observer */
/* relative to the solar system barycenter. Relativistic effects */
/* such as light bending and gravitational delay are not accounted */
/* for in the light time correction performed by this routine. */
/* The velocity of the observer also affects the apparent location */
/* of a target: photons arriving at the observer are subject to a */
/* "raindrop effect" whereby their velocity relative to the observer */
/* is, using a Newtonian approximation, the photons' velocity */
/* relative to the solar system barycenter minus the velocity of the */
/* observer relative to the solar system barycenter. This effect is */
/* called "stellar aberration." Stellar aberration is independent */
/* of the velocity of the target. The stellar aberration formula */
/* used by this routine is non-relativistic. */
/* Stellar aberration corrections are applied after light time */
/* corrections: the light time corrected target position vector is */
/* used as an input to the stellar aberration correction. */
/* When light time and stellar aberration corrections are both */
/* applied to a geometric position vector, the resulting position */
/* vector indicates where the target "appears to be" from the */
/* observer's location. */
/* As opposed to computing the apparent position of a target, one */
/* may wish to compute the pointing direction required for */
/* transmission of photons to the target. This requires correction */
/* of the geometric target position for the effects of light time and */
/* stellar aberration, but in this case the corrections are computed */
/* for radiation traveling from the observer to the target. */
/* The "transmission" light time correction yields the target's */
/* location as it will be when photons emitted from the observer's */
/* location at ET arrive at the target. The transmission stellar */
/* aberration correction is the inverse of the traditional stellar */
/* aberration correction: it indicates the direction in which */
/* radiation should be emitted so that, using a Newtonian */
/* approximation, the sum of the velocity of the radiation relative */
/* to the observer and of the observer's velocity, relative to the */
/* solar system barycenter, yields a velocity vector that points in */
/* the direction of the light time corrected position of the target. */
/* The traditional aberration corrections applicable to observation */
/* and those applicable to transmission are related in a simple way: */
/* one may picture the geometry of the "transmission" case by */
/* imagining the "observation" case running in reverse time order, */
/* and vice versa. */
/* One may reasonably object to using the term "observer" in the */
/* transmission case, in which radiation is emitted from the */
/* observer's location. The terminology was retained for */
/* consistency with earlier documentation. */
/* Below, we indicate the aberration corrections to use for some */
/* common applications: */
/* 1) Find the apparent direction of a target for a remote-sensing */
/* observation: */
/* Use 'LT+S': apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT') is */
/* generally not a good way to obtain an approximation to an */
/* apparent target vector: since light time and stellar */
/* aberration corrections often partially cancel each other, */
/* it may be more accurate to use no correction at all than to */
/* use light time alone. */
/* 2) Find the corrected pointing direction to radiate a signal */
/* to a target: */
/* Use 'XLT+S': apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file: */
/* Use 'NONE'. */
/* 4) Compute the apparent position of a target body relative */
/* to a star or other distant object: */
/* Use 'LT' or 'LT+S' as needed to match the correction */
/* applied to the position of the distant object. For */
/* example, if a star position is obtained from a catalog, */
/* the position vector may not be corrected for stellar */
/* aberration. In this case, to find the angular */
/* separation of the star and the limb of a planet, the */
/* vector from the observer to the planet should be */
/* corrected for light time but not stellar aberration. */
/* 5) Use a geometric state vector as a low-accuracy estimate */
/* of the apparent state for an application where execution */
/* speed is critical: */
/* Use 'NONE'. */
/* 6) While this routine cannot perform the relativistic */
/* aberration corrections required to compute states */
/* with the highest possible accuracy, it can supply the */
/* geometric states required as inputs to these computations: */
/* Use 'NONE', then apply high-accuracy aberration */
/* corrections (not available in the SPICE Toolkit). */
/* Below, we discuss in more detail how the aberration corrections */
/* applied by this routine are computed. */
/* Geometric case */
/* ============== */
/* ZZSPKAP0 begins by computing the geometric position T(ET) of */
/* the target body relative to the solar system barycenter (SSB). */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the geometric position of the target body relative to the */
/* observer. The one-way light time, LT, is given by */
/* | T(ET) - O(ET) | */
/* LT = ------------------- */
/* c */
/* The geometric relationship between the observer, target, and */
/* solar system barycenter is as shown: */
/* SSB ---> O(ET) */
/* | / */
/* | / */
/* | / */
/* | / T(ET) - O(ET) */
/* V V */
/* T(ET) */
/* The returned state consists of the position vector */
/* T(ET) - O(ET) */
/* and a velocity obtained by taking the difference of the */
/* corresponding velocities. In the geometric case, the */
/* returned velocity is actually the time derivative of the */
/* position. */
/* Reception case */
/* ============== */
/* When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is */
/* selected, ZZSPKAP0 computes the position of the target body at */
/* epoch ET-LT, where LT is the one-way light time. Let T(t) and */
/* O(t) represent the positions of the target and observer */
/* relative to the solar system barycenter at time t; then LT is */
/* the solution of the light-time equation */
/* | T(ET-LT) - O(ET) | */
/* LT = ------------------------ (1) */
/* c */
/* The ratio */
/* | T(ET) - O(ET) | */
/* --------------------- (2) */
/* c */
/* is used as a first approximation to LT; inserting (2) into the */
/* RHS of the light-time equation (1) yields the "one-iteration" */
/* estimate of the one-way light time. Repeating the process */
/* until the estimates of LT converge yields the "converged */
/* Newtonian" light time estimate. */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the position of the target body relative to the observer: */
/* T(ET-LT) - O(ET). */
/* SSB ---> O(ET) */
/* | \ | */
/* | \ | */
/* | \ | T(ET-LT) - O(ET) */
/* | \ | */
/* V V V */
/* T(ET) T(ET-LT) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET-LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET-LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET-LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated toward the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as follows: */
/* Let r be the light time corrected vector from the observer */
/* to the object, and v be the velocity of the observer with */
/* respect to the solar system barycenter. Let w be the angle */
/* between them. The aberration angle phi is given by */
/* sin(phi) = v sin(w) / c */
/* Let h be the vector given by the cross product */
/* h = r X v */
/* Rotate r by phi radians about h to obtain the apparent */
/* position of the object. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Transmission case */
/* ================== */
/* When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' are */
/* selected, ZZSPKAP0 computes the position of the target body T */
/* at epoch ET+LT, where LT is the one-way light time. LT is the */
/* solution of the light-time equation */
/* | T(ET+LT) - O(ET) | */
/* LT = ------------------------ (3) */
/* c */
/* Subtracting the geometric position of the observer, O(ET), */
/* gives the position of the target body relative to the */
/* observer: T(ET-LT) - O(ET). */
/* SSB --> O(ET) */
/* / | * */
/* / | * T(ET+LT) - O(ET) */
/* / |* */
/* / *| */
/* V V V */
/* T(ET+LT) T(ET) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET+LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET+LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET+LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated away from the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as in the reception case, but the sign of the */
/* rotation angle is negated. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Neither special nor general relativistic effects are accounted */
/* for in the aberration corrections performed by this routine. */
/* $ Examples */
/* In the following code fragment, ZZSPKSB0 and ZZSPKAP0 are used */
/* to display the position of Io (body 501) as seen from the */
/* Voyager 2 spacecraft (Body -32) at a series of epochs. */
/* Normally, one would call the high-level reader SPKEZR to obtain */
/* state vectors. The example below illustrates the interface */
/* of this routine but is not intended as a recommendation on */
/* how to use the SPICE SPK subsystem. */
/* The use of integer ID codes is necessitated by the low-level */
/* interface of this routine. */
/* IO = 501 */
/* VGR2 = -32 */
/* DO WHILE ( EPOCH .LE. END ) */
/* CALL ZZSPKSB0 ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL ZZSPKAP0 ( IO, EPOCH, 'J2000', STVGR2, */
/* . 'LT+S', STIO, LT ) */
/* CALL RECRAD ( STIO, RANGE, RA, DEC ) */
/* WRITE (*,*) RA * DPR(), DEC * DPR() */
/* EPOCH = EPOCH + DELTA */
/* END DO */
/* $ Restrictions */
/* 1) SPICE Private routine. */
/* 2) The kernel files to be used by ZZSPKAP0 must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 3) Unlike most other SPK state computation routines, this */
/* routine requires that the input state be relative to an */
/* inertial reference frame. Non-inertial frames are not */
/* supported by this routine. */
/* 4) In a future version of this routine, the implementation */
/* of the aberration corrections may be enhanced to improve */
/* accuracy. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-DEC-2004 (NJB) */
/* Based on SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* -& */
/* $ Index_Entries */
/* low-level aberration correction */
/* apparent state from spk file */
/* get apparent state */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of ZZSPKAP0 */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a run-time */
/* error that occurred when ZZSPKAP0 was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, ZZSPKAP0 attempted to look at */
/* ABCORR(3:4). Because ABCORR is a passed length argument, its */
/* length is not guaranteed, and those positions may not exist. */
/* Searching beyond the bounds of a string resulted in a */
/* run-time error at NAIF because NAIF compiles SPICELIB using the */
/* CHECK=BOUNDS option for the DEC VAX/VMX DCL FORTRAN command. */
/* Also, without the local variable CORR, ZZSPKAP0 would have to */
/* modify the value of a passed argument, ABCORR. That's a no no. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Indices of flags in the FLAGS array: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZSPKAP0", (ftnlen)8);
}
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
/* Remove leading and embedded white space from the aberration */
/* correction flag, then convert to upper case. */
cmprss_(" ", &c__0, abcorr, corr2, (ftnlen)1, abcorr_len, (ftnlen)5);
ucase_(corr2, corr, (ftnlen)5, (ftnlen)5);
/* Locate the flag in our list of flags. */
i__ = isrchc_(corr, &c__9, flags, (ftnlen)5, (ftnlen)5);
if (i__ == 0) {
setmsg_("Requested aberration correction # is not supported.", (
ftnlen)51);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(SPKINVALIDOPTION)", (ftnlen)23);
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction. */
xmit = i__ > 5;
uselt = i__ == 2 || i__ == 3 || i__ == 6 || i__ == 7;
usestl = i__ > 1 && odd_(&i__);
usecn = i__ == 4 || i__ == 5 || i__ == 8 || i__ == 9;
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
}
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Find the geometric state of the target body with respect to the */
/* solar system barycenter. Subtract the state of the observer */
/* to get the relative state. Use this to compute the one-way */
/* light time. */
zzspksb0_(targ, et, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where he is. */
if (uselt) {
maxitr = 1;
} else if (usecn) {
maxitr = 3;
} else {
maxitr = 0;
}
i__1 = maxitr;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = *et + ltsign * *lt;
zzspksb0_(targ, &d__1, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* If stellar aberration correction is requested, perform it now. */
/* Stellar aberration corrections are not applied to the target's */
/* velocity. */
if (usestl) {
if (xmit) {
/* This is the transmission case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stlabx_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
} else {
/* This is the reception case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stelab_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
}
}
chkout_("ZZSPKAP0", (ftnlen)8);
return 0;
} /* zzspkap0_ */
/* Subroutine */ int serrpo_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[16] /* was [4][4] */, b[4];
integer i__, j;
real w[12], x[4];
char c2[2];
real r1[4], r2[4], af[16] /* was [4][4] */;
integer iw[4], info;
real anrm, rcond;
extern /* Subroutine */ int spbtf2_(char *, integer *, integer *, real *,
integer *, integer *), spotf2_(char *, integer *, real *,
integer *, integer *), alaesm_(char *, logical *, integer
*);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), spbcon_(char *, integer *, integer *, real
*, integer *, real *, real *, real *, integer *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
real *, real *, real *, integer *), spbrfs_(char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spbtrf_(char *, integer *,
integer *, real *, integer *, integer *), spocon_(char *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sppcon_(char *, integer *, real *, real *,
real *, real *, integer *, integer *), spoequ_(integer *,
real *, integer *, real *, real *, real *, integer *), spbtrs_(
char *, integer *, integer *, integer *, real *, integer *, real *
, integer *, integer *), sporfs_(char *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, real *, real *, real *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotri_(char *, integer *, real *, integer *, integer *), sppequ_(char *, integer *, real *, real *, real *, real
*, integer *), spprfs_(char *, integer *, integer *, real
*, real *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), spptrf_(char *, integer *,
real *, integer *), spptri_(char *, integer *, real *,
integer *), spotrs_(char *, integer *, integer *, real *,
integer *, real *, integer *, integer *), spptrs_(char *,
integer *, integer *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRPO tests the error exits for the REAL routines */
/* for symmetric positive definite matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
/* L10: */
}
b[j - 1] = 0.f;
r1[j - 1] = 0.f;
r2[j - 1] = 0.f;
w[j - 1] = 0.f;
x[j - 1] = 0.f;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "PO")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite matrix. */
/* SPOTRF */
s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotrf_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrf_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotrf_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTF2 */
s_copy(srnamc_1.srnamt, "SPOTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotf2_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotf2_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotf2_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRI */
s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotri_("/", &c__0, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotri_("U", &c_n1, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spotri_("U", &c__2, a, &c__1, &info);
chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOTRS */
s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPORFS */
s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOCON */
s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPOEQU */
s_copy(srnamc_1.srnamt, "SPOEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite packed matrix. */
/* SPPTRF */
s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptrf_("/", &c__0, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrf_("U", &c_n1, a, &info);
chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRI */
s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptri_("/", &c__0, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptri_("U", &c_n1, a, &info);
chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPTRS */
s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPRFS */
s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
spprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
spprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPCON */
s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPPEQU */
s_copy(srnamc_1.srnamt, "SPPEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite band matrix. */
/* SPBTRF */
s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtrf_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtrf_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTF2 */
s_copy(srnamc_1.srnamt, "SPBTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtf2_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbtf2_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBTRS */
s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBRFS */
s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
spbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBCON */
s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPBEQU */
s_copy(srnamc_1.srnamt, "SPBEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
spbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
spbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRPO */
} /* serrpo_ */
/* 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_ */
/* $Procedure MSPELD ( Misspelling diagnosis ) */
/* Subroutine */ int mspeld_(char *word, char *guess, char *cause, ftnlen
word_len, ftnlen guess_len, ftnlen cause_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char last[16];
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
char first[16];
extern /* Subroutine */ int matche_(char *, char *, char *, integer *,
ftnlen, ftnlen, ftnlen);
char diagns[12];
extern /* Subroutine */ int intord_(integer *, char *, ftnlen), suffix_(
char *, integer *, char *, ftnlen, ftnlen);
integer loc;
/* $ Abstract */
/* Diagnose possible spelling errors that might cause a word */
/* to differ from another (known) word. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* COMPARE */
/* ERROR */
/* PARSING */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* WORD I A word that is thought to be misspelled. */
/* GUESS I A word that is thought to be "close" to WORD. */
/* CAUSE O A message indicating the difference between them. */
/* $ Detailed_Input */
/* WORD A word that is thought to be misspelled. */
/* GUESS A word that is thought to be "close" to WORD. */
/* $ Detailed_Output */
/* CAUSE A message that indicates the difference between WORD */
/* and GUESS. */
/* $ Exceptions */
/* 1) CAUSE is blank whenever WORD and GUESS are the same. */
/* $ Files */
/* None. */
/* $ Particulars */
/* A number of spelling errors are due to the lack of cooperation */
/* between the hands that do the typing and the brain that knows */
/* how something should be spelled. Four common errors are: */
/* 1) Leaving out a necessary character. */
/* 2) Adding an extra character. */
/* 3) Mistyping a single character. */
/* 4) Transposing two characters. */
/* This routine creates "friendly" diagnostic messages indicating */
/* whether or not the difference between WORD and GUESS could have */
/* been caused by one of these simple errors. */
/* This routine will typically be used only after the list of */
/* guesses has been narrowed down to words that are "close" to */
/* the unrecognized word. */
/* $ Examples */
/* $ */
/* WORD : LENGHT */
/* GUESS : LENGTH */
/* CAUSE : 'It appears that you have transposed the fifth and */
/* sixth letters of LENGTH (the letters T and H).' */
/* WORD : EPHEMRIS */
/* GUESS : EPHEMERIS */
/* CAUSE : 'It appears that you have left out the sixth letter of */
/* EPHEMERIS. (The sixth letter should be E.)' */
/* WORD : INTWGRATE */
/* WORD : INTEGRATE */
/* CAUSE : 'It appears that you have mistyped the fourth letter */
/* of INTEGRATE. (The fourth letter should be E. You */
/* have W instead.)' */
/* WORD : INTERGER */
/* GUESS: INTEGER */
/* CAUSE 'It appears that you have an extra letter at the fifth */
/* letter of INTERGER. (The fifth letter R should be */
/* removed.)' */
/* WORD : URUNAS */
/* GUESS: URANUS */
/* CAUSE: 'I believe you meant URANUS. However, the actual */
/* spelling error is not a simple one.' */
/* WORD : INTERDENOMINATIONAL */
/* GUESS: INTERDENOMINATIONAL */
/* CAUSE: ' ' */
/* $ Restrictions */
/* Any restrictions that apply to the words compared by MATCHE */
/* apply as well to WORD and GUESS. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Version B1.0.0, 13-APR-1988 (WLT) (IMU) */
/* -& */
/* Local variables */
matche_(word, guess, diagns, &loc, word_len, guess_len, (ftnlen)12);
if (s_cmp(diagns, "IDENTITY", (ftnlen)12, (ftnlen)8) == 0) {
s_copy(cause, " ", cause_len, (ftnlen)1);
} else if (s_cmp(diagns, "TRANSPOSE", (ftnlen)12, (ftnlen)9) == 0) {
intord_(&loc, first, (ftnlen)16);
i__1 = loc + 1;
intord_(&i__1, last, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
lcase_(last, last, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have transposed the ", cause_len, (
ftnlen)40);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("and", &c__1, cause, (ftnlen)3, cause_len);
suffix_(last, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letters of", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_("(the letters", &c__1, cause, (ftnlen)12, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("and", &c__1, cause, (ftnlen)3, cause_len);
i__1 = loc;
suffix_(guess + i__1, &c__1, cause, loc + 1 - i__1, cause_len);
suffix_(").", &c__0, cause, (ftnlen)2, cause_len);
} else if (s_cmp(diagns, "INSERT", (ftnlen)12, (ftnlen)6) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have left out the ", cause_len, (
ftnlen)38);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter should be ", &c__1, cause, (ftnlen)17, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_(".)", &c__0, cause, (ftnlen)2, cause_len);
} else if (s_cmp(diagns, "REPLACE", (ftnlen)12, (ftnlen)7) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have mistyped the ", cause_len, (
ftnlen)38);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter should be ", &c__1, cause, (ftnlen)17, cause_len);
suffix_(guess + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_(". You have ", &c__0, cause, (ftnlen)11, cause_len);
suffix_(word + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("instead.)", &c__1, cause, (ftnlen)9, cause_len);
} else if (s_cmp(diagns, "REMOVE", (ftnlen)12, (ftnlen)6) == 0) {
intord_(&loc, first, (ftnlen)16);
lcase_(first, first, (ftnlen)16, (ftnlen)16);
s_copy(cause, "It appears that you have an extra letter at the ",
cause_len, (ftnlen)48);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter of ", &c__1, cause, (ftnlen)10, cause_len);
suffix_(word, &c__1, cause, word_len, cause_len);
suffix_(". (The ", &c__0, cause, (ftnlen)7, cause_len);
suffix_(first, &c__1, cause, (ftnlen)16, cause_len);
suffix_("letter ", &c__1, cause, (ftnlen)7, cause_len);
suffix_(word + (loc - 1), &c__1, cause, (ftnlen)1, cause_len);
suffix_("should be removed.)", &c__1, cause, (ftnlen)19, cause_len);
} else {
s_copy(cause, "I believe you meant ", cause_len, (ftnlen)20);
suffix_(guess, &c__1, cause, guess_len, cause_len);
suffix_(". However, the actual spelling ", &c__1, cause, (ftnlen)32,
cause_len);
suffix_("error is not a simple one. ", &c__1, cause, (ftnlen)32,
cause_len);
}
return 0;
} /* mspeld_ */
/* Subroutine */ int cerrtr_(char *path, integer *nunit)
{
/* Local variables */
complex a[4] /* was [2][2] */, b[2], w[2], x[2];
char c2[2];
real r1[2], r2[2], rw[2];
integer info;
real scale, rcond;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRTR tests the error exits for the COMPLEX triangular routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0].r = 1.f, a[0].i = 0.f;
a[2].r = 2.f, a[2].i = 0.f;
a[3].r = 3.f, a[3].i = 0.f;
a[1].r = 4.f, a[1].i = 0.f;
infoc_1.ok = TRUE_;
/* Test error exits for the general triangular routines. */
if (lsamen_(&c__2, c2, "TR")) {
/* CTRTRI */
s_copy(srnamc_1.srnamt, "CTRTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrtri_("/", "N", &c__0, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrtri_("U", "/", &c__0, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrtri_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrtri_("U", "N", &c__2, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRTI2 */
s_copy(srnamc_1.srnamt, "CTRTI2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrti2_("/", "N", &c__0, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrti2_("U", "/", &c__0, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrti2_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrti2_("U", "N", &c__2, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRTRS */
s_copy(srnamc_1.srnamt, "CTRTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
/* CTRRFS */
s_copy(srnamc_1.srnamt, "CTRRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRCON */
s_copy(srnamc_1.srnamt, "CTRCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctrcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATRS */
s_copy(srnamc_1.srnamt, "CLATRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
clatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits for the packed triangular routines. */
} else if (lsamen_(&c__2, c2, "TP")) {
/* CTPTRI */
s_copy(srnamc_1.srnamt, "CTPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctptri_("/", "N", &c__0, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctptri_("U", "/", &c__0, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctptri_("U", "N", &c_n1, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPTRS */
s_copy(srnamc_1.srnamt, "CTPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPRFS */
s_copy(srnamc_1.srnamt, "CTPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPCON */
s_copy(srnamc_1.srnamt, "CTPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctpcon_("/", "U", "N", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctpcon_("1", "/", "N", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctpcon_("1", "U", "/", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctpcon_("1", "U", "N", &c_n1, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATPS */
s_copy(srnamc_1.srnamt, "CLATPS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatps_("/", "N", "N", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatps_("U", "/", "N", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatps_("U", "N", "/", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatps_("U", "N", "N", "/", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatps_("U", "N", "N", "N", &c_n1, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits for the banded triangular routines. */
} else if (lsamen_(&c__2, c2, "TB")) {
/* CTBTRS */
s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTBRFS */
s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
c__2, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
c__2, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTBCON */
s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ctbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATBS */
s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
clatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
clatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRTR */
} /* cerrtr_ */
/* Subroutine */ int derrqr_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[4] /* was [2][2] */, b[2];
integer i__, j;
doublereal w[2], x[2], af[4] /* was [2][2] */;
integer info;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *), dorg2r_(
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dorm2r_(char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal
*, doublereal *, integer *, integer *), chkxer_(char *, integer *,
integer *, logical *, logical *), dgeqrs_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *),
dorgqr_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dormqr_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRQR tests the error exits for the DOUBLE PRECISION routines */
/* that use the QR decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for QR factorization */
/* DGEQRF */
s_copy(srnamc_1.srnamt, "DGEQRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEQR2 */
s_copy(srnamc_1.srnamt, "DGEQR2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEQRS */
s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORGQR */
s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorgqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorgqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorgqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorgqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dorgqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORG2R */
s_copy(srnamc_1.srnamt, "DORG2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorg2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorg2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorg2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorg2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorg2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorg2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORMQR */
s_copy(srnamc_1.srnamt, "DORMQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dormqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dormqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dormqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dormqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dormqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dormqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dormqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DORM2R */
s_copy(srnamc_1.srnamt, "DORM2R", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dorm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dorm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRQR */
} /* derrqr_ */
/* Subroutine */ int srqt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *r__, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int sorgrq_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
static real eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define r___ref(a_1,a_2) r__[(a_2)*r_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SRQT02 tests SORGRQ, which generates an m-by-n matrix Q with
orthonornmal rows that is defined as the product of k elementary
reflectors.
Given the RQ factorization of an m-by-n matrix A, SRQT02 generates
the orthogonal matrix Q defined by the factorization of the last k
rows of A; it compares R(m-k+1:m,n-m+1:n) with
A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are
orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
N >= M >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input) REAL array, dimension (LDA,N)
The m-by-n matrix A which was factorized by SRQT01.
AF (input) REAL array, dimension (LDA,N)
Details of the RQ factorization of A, as returned by SGERQF.
See SGERQF for further details.
Q (workspace) REAL array, dimension (LDA,N)
R (workspace) REAL array, dimension (LDA,M)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= N.
TAU (input) REAL array, dimension (M)
The scalar factors of the elementary reflectors corresponding
to the RQ factorization in AF.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
=====================================================================
Quick return if possible
Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
slacpy_("Full", k, &i__1, &af_ref(*m - *k + 1, 1), lda, &q_ref(*m - *
k + 1, 1), lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
slacpy_("Lower", &i__1, &i__2, &af_ref(*m - *k + 2, *n - *k + 1), lda,
&q_ref(*m - *k + 2, *n - *k + 1), lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)6, (ftnlen)6);
sorgrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
slaset_("Full", k, m, &c_b10, &c_b10, &r___ref(*m - *k + 1, *n - *m + 1),
lda);
slacpy_("Upper", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &r___ref(*
m - *k + 1, *n - *k + 1), lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
sgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a_ref(*m - *k + 1,
1), lda, &q[q_offset], lda, &c_b16, &r___ref(*m - *k + 1, *n - *m
+ 1), lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = slange_("1", k, n, &a_ref(*m - *k + 1, 1), lda, &rwork[1]);
resid = slange_("1", k, m, &r___ref(*m - *k + 1, *n - *m + 1), lda, &
rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
slaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
ssyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = slansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of SRQT02 */
} /* srqt02_ */
/* Subroutine */ int ctimtr_(char *line, integer *nn, integer *nval, integer *
nns, integer *nsval, integer *nnb, integer *nbval, integer *nlda,
integer *ldaval, real *timmin, complex *a, complex *b, real *reslts,
integer *ldr1, integer *ldr2, integer *ldr3, integer *nout, ftnlen
line_len)
{
/* Initialized data */
static char subnam[6*2] = "CTRTRI" "CTRTRS";
static char uplos[1*2] = "U" "L";
/* 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,/)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3;
/* 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, info;
static char path[3];
static real time;
static integer isub, nrhs;
static char uplo[1];
static integer i__, n;
static char cname[6];
extern logical lsame_(char *, char *);
extern doublereal sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer iuplo, i3;
static real s1, s2;
static integer ic, nb, in;
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int ctimmg_(integer *, integer *, integer *,
complex *, integer *, integer *, integer *), atimin_(char *, char
*, integer *, char *, logical *, integer *, integer *, ftnlen,
ftnlen, ftnlen), xlaenv_(integer *, integer *);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
static logical timsub[2];
extern /* Subroutine */ int sprtbl_(char *, char *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, ftnlen, ftnlen), ctrtri_(char *, char *, integer *,
complex *, integer *, integer *), ctrtrs_(char *,
char *, char *, integer *, integer *, complex *, integer *,
complex *, integer *, integer *);
static integer lda, ldb, icl, inb, mat;
static real ops;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 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
=======
CTIMTR times CTRTRI and -TRS.
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.
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 size 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.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
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) REAL
The minimum time a subroutine will be timed.
A (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values permitted
for LDA and N.
B (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
RESLTS (output) REAL array, dimension
(LDR1,LDR2,LDR3,NSUBS)
The timing results for each subroutine over the relevant
values of N, NB, 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,NN).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,2*NLDA).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--nval;
--nsval;
--nbval;
--ldaval;
--a;
--b;
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, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__2, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L130;
}
/* Check that N <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nn, &nval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___7.ciunit = *nout;
s_wsfe(&io___7);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L130;
}
/* 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")) {
mat = 11;
} else {
mat = -11;
}
/* Do for each value of N: */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
/* 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 value of NB in NBVAL. Only the blocked
routines are timed in this loop since the other routines
are independent of NB. */
if (timsub[0]) {
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Time CTRTRI */
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
ic = 0;
s1 = second_();
L10:
ctrtri_(uplo, "Non-unit", &n, &a[1], &lda, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
goto L10;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L20:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
goto L20;
}
time = (time - untime) / (real) ic;
ops = sopla_("CTRTRI", &n, &n, &c__0, &c__0, &nb);
reslts_ref(inb, in, i3, 1) = smflop_(&ops, &time, &
info);
/* L30: */
}
} else {
/* Generate a triangular matrix A. */
ctimmg_(&mat, &n, &n, &a[1], &lda, &c__0, &c__0);
}
/* Time CTRTRS */
if (timsub[1]) {
i__3 = *nns;
for (i__ = 1; i__ <= i__3; ++i__) {
nrhs = nsval[i__];
ldb = lda;
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L40:
ctrtrs_(uplo, "No transpose", "Non-unit", &n, &nrhs, &
a[1], &lda, &b[1], &ldb, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L40;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L50:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&c__0, &n, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L50;
}
time = (time - untime) / (real) ic;
ops = sopla_("CTRTRS", &n, &nrhs, &c__0, &c__0, &c__0);
reslts_ref(i__, in, i3, 2) = smflop_(&ops, &time, &
info);
/* L60: */
}
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a table of results. */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L120;
}
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___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L100: */
}
}
io___31.ciunit = *nout;
s_wsle(&io___31);
e_wsle();
for (iuplo = 1; iuplo <= 2; ++iuplo) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, uplos + (iuplo - 1), (ftnlen)1);
e_wsfe();
i3 = (iuplo - 1) * *nlda + 1;
if (isub == 1) {
sprtbl_("NB", "N", nnb, &nbval[1], nn, &nval[1], nlda, &
reslts_ref(1, 1, i3, 1), ldr1, ldr2, nout, (ftnlen)2,
(ftnlen)1);
} else if (isub == 2) {
sprtbl_("NRHS", "N", nns, &nsval[1], nn, &nval[1], nlda, &
reslts_ref(1, 1, i3, 2), ldr1, ldr2, nout, (ftnlen)4,
(ftnlen)1);
}
/* L110: */
}
L120:
;
}
L130:
return 0;
/* End of CTIMTR */
} /* ctimtr_ */
/* $Procedure ZZPLATFM ( Private --- Get platform attributes ) */
/* Subroutine */ int zzplatfm_(char *key, char *value, ftnlen key_len, ftnlen
value_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer);
/* Local variables */
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
integer index;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
static char keyval[64*6];
char keycpy[64];
static char attcpy[32*7];
/* $ Abstract */
/* Return platform ID and various attributes of the intended */
/* environment */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* KEY I String indicating what information to return. */
/* VALUE O String containing the requested information. */
/* $ Detailed_Input */
/* KEY is a string value that indicates which platform */
/* specific information is desired. Acceptable inputs */
/* are: */
/* 'SYSTEM' - System Identification String */
/* 'O/S' - Operating System or Environment */
/* 'COMPILER' - NAIF Supported Compiler */
/* 'FILE_FORMAT' - Native Binary File Format */
/* 'TEXT_FORMAT' - Native Text File Format */
/* 'READS_BFF' - List of supported binary file */
/* formats. */
/* Note: The comparison is case-insensitive, and the */
/* supplied value must fit into a string buffer */
/* KYSIZE characters in length. */
/* $ Detailed_Output */
/* VALUE is the string that holds the information requested */
/* by the input string KEY. VALUE must be able to */
/* contain the maximum number of characters returned */
/* by this routine, WDSIZE, or truncation will occur. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the KEY is invalid, then VALUE is set to the value */
/* stored in the character string parameter DEFRPY defined */
/* below. */
/* 2) If VALUE is not large enough to contain the requested */
/* KEY's value, then truncation will occur. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine serves to identify the platform and compiler */
/* used in creating SPICELIB. It is provided so that routines */
/* and programs can make run-time decisions based upon the */
/* ambient Fortran environment. */
/* Operating Systems: */
/* This routine is now aware of the operating systems for which */
/* the code is intended for compilation. In some cases this may */
/* be more than one operating system, particularly in the case */
/* of the PC. */
/* Binary File Format: */
/* This routine now adds the capability to return at run time */
/* the binary file architecture that is native to the system. */
/* Text File Format: */
/* This routine now has the capability to return at run time */
/* the mechanism (or line terminator) used to delimit lines */
/* in text files. In most cases it will return common labels */
/* for the special characters FORTRAN considers line break */
/* indicators. */
/* Binary File Formats Read: */
/* This returns a space delimited list of all the binary file */
/* formats this environment can read for DAF/DAS based files. */
/* $ Examples */
/* This routine could be used so that a single routine */
/* could be written that translates the meaning of IOSTAT values */
/* that depend upon the machine and compiler. At run time */
/* the routine could look up the appropriate message to associate */
/* with an IOSTAT value. */
/* $ Restrictions */
/* 1) VALUE must be large enough to contain the requested */
/* information, otherwise truncation will occur. */
/* 2) The string passed in via the KEY input must be capable */
/* of being properly copied into the KEYCPY buffer internal */
/* to this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.0, 10-MAR-2014 (BVS) */
/* Updated for: */
/* PC-CYGWIN-64BIT-GCC_C */
/* PC-CYGWIN-64BIT-GFORTRAN */
/* PC-CYGWIN-GFORTRAN */
/* PC-LINUX-64BIT-IFORT */
/* SUN-SOLARIS-64BIT-INTEL */
/* environments. */
/* - SPICELIB Version 2.9.0, 16-MAR-2010 (EDW) */
/* Updated for: */
/* - MAC-OSX-64BIT-INTEL_C */
/* - PC-64BIT-MS_C */
/* - SUN-SOLARIS-64BIT-NATIVE_C */
/* MAC-OSX-64BIT-GFORTRAN */
/* MAC-OSX-64BIT-IFORT */
/* PC-LINUX-64BIT-GFORTRAN */
/* PC-WINDOWS-64BIT-IFORT */
/* SUN-SOLARIS-INTEL-64BIT-CC_C */
/* SUN-SOLARIS-INTEL-CC_C */
/* SUN-SOLARIS-INTEL */
/* environments. */
/* - SPICELIB Version 2.8.0, 12-JAN-2009 (EDW) */
/* Added MAC-OSX-GFORTRAN PC-LINUX-GFORTRAN environments. */
/* - SPICELIB Version 2.7.0, 19-FEB-2008 (BVS) */
/* Added PC-LINUX-IFORT environment. */
/* - SPICELIB Version 2.6.0, 15-NOV-2006 (NJB) */
/* Added PC-WINDOWS-IFORT, MAC-OSX-IFORT, and MAC-OSX-INTEL_C */
/* environments. */
/* - SPICELIB Version 2.5.0, 21-FEB-2006 (NJB) */
/* Added PC-LINUX-64BIT-GCC_C environment. */
/* Corrected error in in-line comments: changed keyword */
/* from FILE_ARCH to FILE_FORMAT. */
/* - SPICELIB Version 2.4.0, 14-MAR-2005 (BVS) */
/* Added SUN-SOLARIS-64BIT-GCC_C environment. */
/* - SPICELIB Version 2.3.0, 31-DEC-2004 (BVS) */
/* Added PC CYGWIN environments. Changed OS for PC-LAHEY, */
/* PC-DIGITAL, and PC-MS_C to 'MICROSOFT WINDOWS'. */
/* - SPICELIB Version 2.2.0, 07-JUL-2002 (EDW) */
/* Added Mac OS X Unix environment. */
/* - SPICELIB Version 2.1.0, 06-FEB-2002 (FST) */
/* Updated the 'TEXT_FORMAT' key value for the PC-LINUX_C */
/* environment. Previous versions incorrectly indicated */
/* 'CR-LF' as line terminators. */
/* - SPICELIB Version 2.0.0, 05-JUN-2001 (FST) */
/* Added TEXT_FORMAT and READS_BFF key/value pairs. */
/* Modified the header slightly to improve word choice; */
/* specifically binary file format replaces file */
/* architecture. */
/* Updated the compiler entry for the PC-LINUX */
/* environment to refer to g77 as opposed to f2c. */
/* Updated the compiler entry for the MACPPC environment. */
/* This environment is now officially tied to Absoft */
/* Fortran. */
/* Updated the compiler entry for the PC-LAHEY environment. */
/* The compiler for this environment is LF95, the latest */
/* offering from Lahey. */
/* - SPICELIB Version 1.0.0, 22-FEB-1999 (FST) */
/* -& */
/* $ Index_Entries */
/* fetch platform dependent information */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Array index parameters for each of the key/value pairs. */
/* SYSTEM Index. */
/* O/S Index. */
/* Compiler Index. */
/* Binary File Format Index. */
/* Text File Format Index */
/* Reads Binary File Format Index. */
/* Size of the buffer in which KEY is placed. */
/* Maximum Size of local string returned in VALUE */
/* Number of Platform Dependent values stored here. */
/* Default Reply in the event of an invalid KEY. */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Make the initial assignments to the saved character array. */
if (first) {
/* Store the keys in the KEYVAL array. */
s_copy(keyval, "SYSTEM", (ftnlen)64, (ftnlen)6);
s_copy(keyval + 64, "O/S", (ftnlen)64, (ftnlen)3);
s_copy(keyval + 128, "COMPILER", (ftnlen)64, (ftnlen)8);
s_copy(keyval + 192, "FILE_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 256, "TEXT_FORMAT", (ftnlen)64, (ftnlen)11);
s_copy(keyval + 320, "READS_BFF", (ftnlen)64, (ftnlen)9);
/* Set the default reply to be the zero'th component of ATTCPY. */
/* This obviates IF-THEN-ELSE branching all together. */
s_copy(attcpy, "<UNAVAILABLE> ", (ftnlen)32, (
ftnlen)32);
/* Platform/Environment specific assignments follow. */
s_copy(attcpy + 32, "PC", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 64, "LINUX", (ftnlen)32, (ftnlen)5);
s_copy(attcpy + 96, "GCC/64BIT", (ftnlen)32, (ftnlen)9);
s_copy(attcpy + 128, "LTL-IEEE", (ftnlen)32, (ftnlen)8);
s_copy(attcpy + 160, "LF", (ftnlen)32, (ftnlen)2);
s_copy(attcpy + 192, "BIG-IEEE LTL-IEEE", (ftnlen)32, (ftnlen)17);
/* Don't execute these assignments again. */
first = FALSE_;
}
/* Determine which KEY was passed in; do this by converting KEY */
/* to the known member of the equivalence class of possible */
/* values. */
ucase_(key, keycpy, key_len, (ftnlen)64);
ljust_(keycpy, keycpy, (ftnlen)64, (ftnlen)64);
/* Find out which key we were given. In the event that one of the */
/* KEYVALs (or some equivalent string) was not passed in, ISRCHC */
/* returns a value of zero. */
index = isrchc_(keycpy, &c__6, keyval, (ftnlen)64, (ftnlen)64);
s_copy(value, attcpy + (((i__1 = index) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"attcpy", i__1, "zzplatfm_", (ftnlen)425)) << 5), value_len, (
ftnlen)32);
return 0;
} /* zzplatfm_ */
/* Subroutine */ int derrtz_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[4] /* was [2][2] */, w[2];
char c2[2];
doublereal tau[2];
integer info;
extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dtzrqf_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *), dtzrzf_(integer *, integer *
, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRTZ tests the error exits for DTZRQF and STZRZF. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0] = 1.;
a[2] = 2.;
a[3] = 3.;
a[1] = 4.;
w[0] = 0.;
w[1] = 0.;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "TZ")) {
/* Test error exits for the trapezoidal routines. */
/* DTZRQF */
s_copy(srnamc_1.srnamt, "DTZRQF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dtzrqf_(&c_n1, &c__0, a, &c__1, tau, &info);
chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dtzrqf_(&c__1, &c__0, a, &c__1, tau, &info);
chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dtzrqf_(&c__2, &c__2, a, &c__1, tau, &info);
chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DTZRZF */
s_copy(srnamc_1.srnamt, "DTZRZF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dtzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dtzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dtzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info);
chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dtzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info);
chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRTZ */
} /* derrtz_ */