/* Subroutine */ int zdrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
doublereal roldc, rcond, scond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int zppt01_(char *, integer *, doublecomplex *,
doublecomplex *, doublereal *, doublereal *), zppt02_(
char *, integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
char xtype[1];
extern /* Subroutine */ int zppsv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *),
zlatb4_(char *, integer *, integer *, integer *, char *, integer *
, integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
doublereal rcondc;
logical nofact;
char packit[1];
integer iequed;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
doublereal ainvnm;
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlaqhp_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublereal *, char *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal result[6];
extern /* Subroutine */ int zppequ_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublereal *, integer *),
zpptrf_(char *, integer *, doublecomplex *, integer *),
zpptri_(char *, integer *, doublecomplex *, integer *),
zerrvx_(char *, integer *), zppsvx_(char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, char *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 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 */
/* ======= */
/* ZDRVPP tests the driver routines ZPPSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
/* 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 = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
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];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
rcondc = 1. / cndnum;
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L120;
}
/* 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;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
zlaipd_(&n, &a[1], &c__2, &c__1);
} else {
zlaipd_(&n, &a[1], &n, &c_n1);
}
/* Save a copy of the matrix A in ASAV. */
zcopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by ZPPSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
zcopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
zppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
zlaqhp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in ZGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = zlanhp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
zpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
zcopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
zpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
zcopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test ZPPSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "ZPPSV ", (ftnlen)6, (
ftnlen)6);
zppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from ZPPSV . */
if (info != izero) {
alaerh_(path, "ZPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
zppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
zppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "ZPPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test ZPPSVX --- */
if (! prefac && npp > 0) {
zlaset_("Full", &npp, &c__1, &c_b63, &c_b63, &
afac[1], &npp);
}
zlaset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
zlaqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using ZPPSVX. */
s_copy(srnamc_1.srnamt, "ZPPSVX", (ftnlen)6, (ftnlen)
6);
zppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
(*nrhs << 1) + 1], &info);
/* Check the error code from ZPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "ZPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
zppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
zppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
zppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from ZPPSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "ZPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "ZPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPP */
} /* zdrvpp_ */
/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
{
/* Format strings */
static char fmt_99999[] = "(\002 F"
"AIL\002)";
static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
" \002,\002 COMP TRU"
"E DIFFERENCE\002,/1x)";
static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer id;
/* Fortran I/O blocks */
static cilist io___110 = { 0, 6, 0, fmt_99999, 0 };
static cilist io___111 = { 0, 6, 0, fmt_99998, 0 };
static cilist io___113 = { 0, 6, 0, fmt_99997, 0 };
/* ********************************* ITEST1 ************************* */
/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
/* EQUALITY. */
/* C. L. LAWSON, JPL, 1974 DEC 10 */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
if (*icomp == *itrue) {
goto L40;
}
/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
if (! combla_1.pass) {
goto L20;
}
/* PRINT FAIL MESSAGE AND HEADER. */
combla_1.pass = FALSE_;
s_wsfe(&io___110);
e_wsfe();
s_wsfe(&io___111);
e_wsfe();
L20:
id = *icomp - *itrue;
s_wsfe(&io___113);
do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
e_wsfe();
L40:
return 0;
} /* itest1_ */
/* Subroutine */ int dchkqr_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar,
doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, 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;
extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nfail, iseed[4];
extern /* Subroutine */ int dqrt01_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dqrt02_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
);
integer minmn;
extern /* Subroutine */ int dqrt03_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
);
integer nerrs, lwork;
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 *);
extern logical dgennd_(integer *, integer *, doublereal *, integer *);
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 dgeqrs_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *), dlatms_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublereal *,
integer *, doublereal *, integer *),
xlaenv_(integer *, integer *), derrqr_(char *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKQR tests DGEQRF, DORGQR and DORMQR. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--ar;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--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, "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) {
derrqr_(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 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)32, (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 L50;
}
/* Set some values for K: the first value must be MINMN, */
/* corresponding to the call of DQRT01; other values are */
/* used in the calls of DQRT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
for (i__ = 1; i__ <= 8; ++i__) {
result[i__ - 1] = 0.;
}
nt = 2;
if (ik == 1) {
/* Test DGEQRF */
dqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
if (! dgennd_(&m, &n, &af[1], &lda)) {
result[7] = *thresh * 2;
}
++nt;
} else if (m >= n) {
/* Test DORGQR, using factorization */
/* returned by DQRT01 */
dqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
}
if (m >= k) {
/* Test DORMQR, using factorization returned */
/* by DQRT01 */
dqrt03_(&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 DGEQRS 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, "DLARHS", (ftnlen)32,
(ftnlen)6);
dlarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)32,
(ftnlen)6);
dgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from DGEQRS. */
if (info != 0) {
alaerh_(path, "DGEQRS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
dget02_("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. */
i__5 = nt;
for (i__ = 1; i__ <= i__5; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKQR */
} /* dchkqr_ */
/* Subroutine */ int gettxt_()
{
/* System generated locals */
integer i__1;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_rsfe(), do_fio(), e_rsfe(), i_indx(), f_open(), f_rew(), s_wsfe(
), e_wsfe(), s_cmp();
/* Subroutine */ int s_stop();
/* Local variables */
static integer i__, j;
static char filen[50], ch[1];
static integer is[3];
extern /* Character */ VOID getnam_();
extern /* Subroutine */ int upcase_();
static char oldkey[80], ch2[1];
/* Fortran I/O blocks */
static cilist io___2 = { 1, 5, 1, "(A)", 0 };
static cilist io___7 = { 1, 4, 1, "(A)", 0 };
static cilist io___8 = { 1, 4, 1, "(A)", 0 };
static cilist io___9 = { 1, 5, 1, "(A)", 0 };
static cilist io___10 = { 1, 5, 1, "(A)", 0 };
static cilist io___11 = { 1, 4, 1, "(A)", 0 };
static cilist io___12 = { 1, 5, 1, "(A)", 0 };
static cilist io___13 = { 1, 5, 1, "(A)", 0 };
static cilist io___14 = { 1, 5, 1, "(A)", 0 };
static cilist io___15 = { 1, 4, 1, "(A)", 0 };
static cilist io___16 = { 1, 5, 1, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___18 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 1, 5, 1, "(A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(A,I2,A)", 0 };
static cilist io___24 = { 0, 6, 0, "(A)", 0 };
static cilist io___25 = { 0, 6, 0, "(A)", 0 };
is[0] = 161;
is[1] = 81;
is[2] = 1;
s_copy(keywrd_1.keywrd, " ", (ftnlen)241, (ftnlen)1);
s_copy(titles_1.koment, " NULL ", (ftnlen)81, (ftnlen)10);
s_copy(titles_1.title, " NULL ", (ftnlen)81, (ftnlen)10);
i__1 = s_rsfe(&io___2);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd, (ftnlen)80);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd, (ftnlen)80, (ftnlen)241);
upcase_(keywrd_1.keywrd, (ftnlen)80);
if (i_indx(keywrd_1.keywrd, "SETUP", (ftnlen)241, (ftnlen)5) != 0) {
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1), (
ftnlen)1);
i__1 = i__ + 5;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 1 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___7);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
i__1 = s_rsfe(&io___8);
if (i__1 != 0) {
goto L10;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L10;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L10;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L10:
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = e_rsfe();
L100002:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, " +", (ftnlen)80, (ftnlen)2) != 0) {
/* READ SECOND KEYWORD LINE */
i__1 = s_rsfe(&io___10);
if (i__1 != 0) {
goto L100003;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100003;
}
i__1 = e_rsfe();
L100003:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___11);
if (i__1 != 0) {
goto L20;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L20;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L20;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L20:
;
} else if (i_indx(keywrd_1.keywrd + 80, " +", (ftnlen)80, (ftnlen)2)
!= 0) {
/* READ THIRD KEYWORD LINE */
i__1 = s_rsfe(&io___12);
if (i__1 != 0) {
goto L100004;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100004;
}
i__1 = e_rsfe();
L100004:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
}
/* READ TITLE LINE */
i__1 = s_rsfe(&io___13);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = e_rsfe();
L100005:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, "&", (ftnlen)80, (ftnlen)1) != 0) {
i__1 = s_rsfe(&io___14);
if (i__1 != 0) {
goto L100006;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100006;
}
i__1 = e_rsfe();
L100006:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
/* write(*,*)' <'//FILEN//'>' */
/* stop */
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___15);
if (i__1 != 0) {
goto L30;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L30;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L30;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100007;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100007;
}
i__1 = e_rsfe();
L100007:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
L30:
;
} else if (i_indx(keywrd_1.keywrd + 80, "&", (ftnlen)80, (ftnlen)1) !=
0) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L100008;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100008;
}
i__1 = e_rsfe();
L100008:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else {
i__1 = s_rsfe(&io___18);
if (i__1 != 0) {
goto L100009;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100009;
}
i__1 = e_rsfe();
L100009:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
} else {
i__1 = s_rsfe(&io___19);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = e_rsfe();
L100010:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
goto L50;
L40:
s_wsfe(&io___20);
do_fio(&c__1, " SETUP FILE MISSING OR CORRUPT", (ftnlen)30);
e_wsfe();
L50:
for (j = 1; j <= 3; ++j) {
i__1 = is[j - 1] - 1;
if (s_cmp(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1) !=
0) {
i__1 = is[j - 1] - 1;
s_copy(ch, keywrd_1.keywrd + i__1, (ftnlen)1, is[j - 1] - i__1);
i__1 = is[j - 1] - 1;
s_copy(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1);
for (i__ = is[j - 1] + 1; i__ <= 239; ++i__) {
*(unsigned char *)ch2 = *(unsigned char *)&keywrd_1.keywrd[
i__ - 1];
*(unsigned char *)&keywrd_1.keywrd[i__ - 1] = *(unsigned char
*)ch;
*(unsigned char *)ch = *(unsigned char *)ch2;
i__1 = i__;
if (s_cmp(keywrd_1.keywrd + i__1, " ", i__ + 2 - i__1, (
ftnlen)2) == 0) {
i__1 = i__;
s_copy(keywrd_1.keywrd + i__1, ch, i__ + 1 - i__1, (
ftnlen)1);
goto L70;
}
/* L60: */
}
s_wsfe(&io___23);
do_fio(&c__1, " LINE", (ftnlen)5);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, " OF KEYWORDS DOES NOT HAVE ENOUGH", (ftnlen)33);
e_wsfe();
s_wsfe(&io___24);
do_fio(&c__1, " SPACES FOR PARSING. PLEASE CORRECT LINE.", (
ftnlen)42);
e_wsfe();
s_stop("", (ftnlen)0);
L70:
;
}
/* L80: */
}
return 0;
L90:
s_wsfe(&io___25);
do_fio(&c__1, " ERROR IN READ OF FIRST THREE LINES", (ftnlen)35);
e_wsfe();
L100:
s_stop("", (ftnlen)0);
} /* gettxt_ */
/* Subroutine */ int pdvout_(integer *comm, integer *lout, integer *n,
doublereal *sx, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Format strings */
static char fmt_9999[] = "(/1x,a,/1x,a)";
static char fmt_9998[] = "(1x,i4,\002 - \002,i4,\002:\002,1p,10d12.3)";
static char fmt_9997[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,8d14.5)";
static char fmt_9996[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,6d18.9)";
static char fmt_9995[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,5d24.13)";
static char fmt_9994[] = "(1x,\002 \002)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, k1, k2, lll;
static char line[80];
static integer ierr, myid;
extern /* Subroutine */ int mpi_comm_rank__(integer *, integer *, integer
*);
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9994, 0 };
/* ... */
/* .. MPI VARIABLES AND FUNCTIONS .. */
/* .. Variable Declaration .. */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Determine processor configuration */
/* Parameter adjustments */
--sx;
/* Function Body */
mpi_comm_rank__(comm, &myid, &ierr);
/* .. Only Processor 0 will write to file LOUT .. */
if (myid == 0) {
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___6.ciunit = *lout;
s_wsfe(&io___6);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*n <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L30: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___11.ciunit = *lout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L40: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L50: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___13.ciunit = *lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L60: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 10) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 9;
k2 = min(i__2,i__3);
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L70: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 8) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 7;
k2 = min(i__2,i__3);
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L80: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 6) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 5;
k2 = min(i__2,i__3);
io___16.ciunit = *lout;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L90: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&sx[i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L100: */
}
}
}
io___18.ciunit = *lout;
s_wsfe(&io___18);
e_wsfe();
}
return 0;
} /* pdvout_ */
/* Subroutine */ int dchkqp_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublereal *a, doublereal *copya, doublereal *s, doublereal *copys,
doublereal *tau, doublereal *work, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer ilow, nrun;
integer ihigh, nfail, iseed[4], imode;
integer mnmin, istep, nerrs, lwork;
doublereal result[3];
/* Fortran I/O blocks */
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKQP tests DGEQPF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX) */
/* 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;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--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, "QP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
derrqp_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n), i__3 =
max(i__3,i__4), i__4 = m * n + (mnmin << 1) + (n << 2);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L60;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
dlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
/* Compute the QR factorization with pivoting of A */
s_copy(srnamc_1.srnamt, "DGEQPF", (ftnlen)32, (ftnlen)6);
dgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
&lwork);
/* Compute norm( A*P - Q*R ) */
result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
tau[1], &iwork[1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
L60:
;
}
/* L70: */
}
/* L80: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of DCHKQP */
return 0;
} /* dchkqp_ */
/* Subroutine */ int schktp_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
nmax, real *ap, real *ainvp, real *b, real *x, real *xact, real *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
"2.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
"\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
",i2,\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
"\002, test(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2[2], i__3, i__4[3], i__5[4];
char ch__1[2], ch__2[3], ch__3[4];
/* Local variables */
integer i__, k, n, in, lda, lap;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
integer idiag;
real scale;
integer nfail, iseed[4];
real rcond;
real anorm;
integer itran;
char trans[1];
integer iuplo, nerrs;
char xtype[1];
real rcondc, rcondi;
real rcondo, ainvnm;
real result[9];
/* Fortran I/O blocks */
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS */
/* 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 column 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. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. NMAX >= the */
/* maximumm value of N in NVAL. */
/* AP (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINVP (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainvp;
--ap;
--nsval;
--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, "TP", (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) {
serrtr_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL */
n = nval[in];
lda = max(1,n);
lap = lda * (lda + 1) / 2;
*(unsigned char *)xtype = 'N';
for (imat = 1; imat <= 10; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L70;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Call SLATTP to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
slattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
&x[1], &work[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
/* + TEST 1 */
/* Form the inverse of A. */
if (n > 0) {
scopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
}
s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)32, (ftnlen)6);
stptri_(uplo, diag, &n, &ainvp[1], &info);
/* Check error code from STPTRI. */
if (info != 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = uplo;
i__2[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
alaerh_(path, "STPTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = slantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
ainvnm = slantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times its */
/* inverse. Also compute the 1-norm condition number of A. */
stpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &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___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (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__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
6);
slarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)32, (ftnlen)
6);
stptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
lda, &info);
/* Check error code from STPTRS. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = uplo;
i__4[1] = 1, a__2[1] = trans;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPTRS", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
stpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
lda, &b[1], &lda, &work[1], &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution and */
/* compute error bounds. */
s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)32, (ftnlen)
6);
stprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
&work[1], &iwork[1], &info);
/* Check error code from STPRFS. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = uplo;
i__4[1] = 1, a__2[1] = trans;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPRFS", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
stpt05_(uplo, trans, diag, &n, &nrhs, &ap[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___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (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;
}
/* L20: */
}
nrun += 5;
/* L30: */
}
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)32, (ftnlen)6);
stpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
iwork[1], &info);
/* Check error code from STPCON. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = norm;
i__4[1] = 1, a__2[1] = uplo;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPCON", &info, &c__0, ch__2, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
, &result[6]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, "STPCON", (ftnlen)6);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (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: */
}
/* L60: */
}
L70:
;
}
/* Use pathological test matrices to test SLATPS. */
for (imat = 11; imat <= 18; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
/* Call SLATTP to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
slattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
, &work[1], &info);
/* + TEST 8 */
/* Solve the system op(A)*x = b. */
s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)32, (ftnlen)6);
scopy_(&n, &x[1], &c__1, &b[1], &c__1);
slatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
&rwork[1], &info);
/* Check error code from SLATPS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = uplo;
i__5[1] = 1, a__3[1] = trans;
i__5[2] = 1, a__3[2] = diag;
i__5[3] = 1, a__3[3] = "N";
s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
work[1], &result[7]);
/* + TEST 9 */
/* Solve op(A)*x = b again with NORMIN = 'Y'. */
scopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
slatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
scale, &rwork[1], &info);
/* Check error code from SLATPS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = uplo;
i__5[1] = 1, a__3[1] = trans;
i__5[2] = 1, a__3[2] = diag;
i__5[3] = 1, a__3[3] = "Y";
s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
work[1], &result[8]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SLATPS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (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(real)
);
e_wsfe();
++nfail;
}
if (result[8] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "SLATPS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (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__9, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
nrun += 2;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKTP */
} /* schktp_ */
/* Subroutine */ int derrac_(integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
"ror exits\002)";
static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
"s of the error \002,\002exits ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4], c__[4];
integer i__, j;
doublereal r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4] */;
integer info, iter;
doublereal work[16];
real swork[16];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dsposv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* May 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRAC tests the error exits for DSPOSV. */
/* Arguments */
/* ========= */
/* 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__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
c__[j - 1] = 0.;
r__[j - 1] = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
s_copy(srnamc_1.srnamt, "DSPOSV", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dsposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dsposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dsposv_("U", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dsposv_("U", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dsposv_("U", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
if (infoc_1.ok) {
io___17.ciunit = infoc_1.nout;
s_wsfe(&io___17);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
e_wsfe();
} else {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of DERRAC */
} /* derrac_ */
/* Subroutine */ int dchkps_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nrank, integer *rankval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *perm, integer *piv, doublereal *work,
doublereal *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
" \002,i2,\002, Ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_dceiling(doublereal *), s_wsfe(cilist *), do_fio(integer *,
char *, ftnlen), e_wsfe(void);
/* Local variables */
integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
doublereal tol;
integer mode, imat, info, rank;
char path[3], dist[1], uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], irank, nimat;
extern /* Subroutine */ int dpst01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, integer *);
doublereal anorm;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int dlatb5_(char *, integer *, integer *, char *,
integer *, integer *, doublereal *, integer *, doublereal *, char
*), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatmt_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, integer *, char *, doublereal *, integer *,
doublereal *, integer *), xlaenv_(integer
*, integer *), derrps_(char *, integer *), dpstrf_(char *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *);
doublereal result;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPS tests DPSTRF. */
/* 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 block size NB. */
/* NRANK (input) INTEGER */
/* The number of values of RANK contained in the vector RANKVAL. */
/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the block size NB. */
/* 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) */
/* PERM (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* PIV (workspace) INTEGER array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*3) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--piv;
--perm;
--afac;
--a;
--rankval;
--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, "PS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L100: */
}
/* Test the error exits */
if (*tsterr) {
derrps_(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);
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 L140;
}
/* Do for each value of RANK in RANKVAL */
i__3 = *nrank;
for (irank = 1; irank <= i__3; ++irank) {
/* Only repeat test 3 to 5 for different ranks */
/* Other tests use full rank */
if ((imat < 3 || imat > 5) && irank > 1) {
goto L130;
}
d__1 = n * (doublereal) rankval[irank] / 100.;
rank = i_dceiling(&d__1);
/* 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 DLATB5 and generate a test matrix */
/* with DLATMT. */
dlatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMT", (ftnlen)32, (ftnlen)6);
dlatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
lda, &work[1], &info);
/* Check error code from DLATMT. */
if (info != 0) {
alaerh_(path, "DLATMT", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L120;
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the pivoted L*L' or U'*U factorization */
/* of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)
6);
/* Use default tolerance */
tol = -1.;
dpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
&tol, &work[1], &info);
/* Check error code from DPSTRF. */
if (info < izero || info != izero && rank == n ||
info <= izero && rank < n) {
alaerh_(path, "DPSTRF", &info, &izero, uplo, &n, &
n, &c_n1, &c_n1, &nb, &imat, &nfail, &
nerrs, nout);
goto L110;
}
/* Skip the test if INFO is not 0. */
if (info != 0) {
goto L110;
}
/* Reconstruct matrix from factors and compute residual. */
/* PERM holds permuted L*L^T or U^T*U */
dpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
1], &lda, &piv[1], &rwork[1], &result, &
comprank);
/* Print information about the tests that did not pass */
/* the threshold or where computed rank was not RANK. */
if (n == 0) {
comprank = 0;
}
rankdiff = rank - comprank;
if (result >= *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 *)&rank, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&rankdiff, (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 *)&result, (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L110:
;
}
L120:
;
}
L130:
;
}
L140:
;
}
/* L150: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPS */
} /* dchkps_ */
/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Local variables */
doublecomplex e[400] /* was [20][20] */;
integer i__, j, n;
doublereal x;
integer ihi;
doublecomplex ein[400] /* was [20][20] */;
integer ilo;
doublereal eps;
integer knt, info, lmax[2];
doublereal rmax, vmax, scale[20];
integer ninfo;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *);
doublereal safmin;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 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 .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKBK tests ZGEBAK, a routine for backward transformation of */
/* the computed right or left eigenvectors if the orginal matrix */
/* was preprocessed by balance subroutine ZGEBAL. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = i__ + j * 20 - 21;
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e[i__ + j *
20 - 21]), abs(d__2)) > safmin) {
i__4 = i__ + j * 20 - 21;
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e[i__ +
j * 20 - 21]), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
doublecomplex *work, integer *nwork, doublereal *rwork, integer *
iwork, logical *select, doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
doublereal ulp, cond;
integer jcol, nmax;
doublereal unfl, ovfl, temp1, temp2;
logical badnn, match;
integer imode;
doublereal dumma[4];
integer iinfo;
doublereal conds;
extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *);
doublereal aninv, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublecomplex cdumma[4];
integer idumma[1];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
char *, integer *, integer *, integer *), zlatme_(integer
*, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, char *, char *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
doublereal rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrevc_(char
*, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zunmhr_(char *, char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* ZGEHRD factors A as U H U' , where ' means conjugate */
/* transpose, H is hessenberg, and U is unitary. */
/* ZUNGHR generates the unitary matrix U. */
/* ZUNMHR multiplies a matrix by the unitary matrix U. */
/* ZHSEQR factors H as Z T Z' , where Z is unitary and T */
/* is upper triangular. It also computes the eigenvalues, */
/* w(1), ..., w(n); we define a diagonal matrix W whose */
/* (diagonal) entries are the eigenvalues. */
/* ZTREVC computes the left eigenvector matrix L and the */
/* right eigenvector matrix R for the matrix T. The */
/* columns of L are the complex conjugates of the left */
/* eigenvectors of T. The columns of R are the right */
/* eigenvectors of T. L is lower triangular, and R is */
/* upper triangular. */
/* ZHSEIN computes the left eigenvector matrix Y and the */
/* right eigenvector matrix X for the matrix H. The */
/* columns of Y are the complex conjugates of the left */
/* eigenvectors of H. The columns of X are the right */
/* eigenvectors of H. Y is lower triangular, and X is */
/* upper triangular. */
/* When ZCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**H | / ( |A| n ulp ) */
/* (2) | I - UU**H | / ( n ulp ) */
/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
/* (4) | I - ZZ**H | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* ZCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, ZCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to ZCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by ZGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by ZHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - COMPLEX*16 array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by ZHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZGEHRD. */
/* Modified. */
/* Z - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by ZHSEQR. */
/* Modified. */
/* UZ - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* W1 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a full Schur */
/* decomposition H = Z T Z'. On exit, W1 contains the */
/* eigenvalues of the matrix in A. */
/* Modified. */
/* W3 - COMPLEX*16 array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a partial Schur */
/* decomposition (Z not computed, T only computed as much */
/* as is necessary for determining eigenvalues). On exit, */
/* W3 contains the eigenvalues of the matrix in A, possibly */
/* perturbed by ZHSEIN. */
/* Modified. */
/* EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the (upper triangular) left */
/* eigenvector matrix for the matrix in T1. */
/* Modified. */
/* EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. */
/* Modified. */
/* EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the left eigenvector matrix */
/* for the matrix in H. */
/* Modified. */
/* EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the matrix in H. */
/* Modified. */
/* UU - COMPLEX*16 array, dimension (LDU,max(NN)) */
/* Details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* TAU - COMPLEX*16 array, dimension (max(NN)) */
/* Further details of the unitary matrix computed by ZGEHRD. */
/* Modified. */
/* WORK - COMPLEX*16 array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* RWORK - DOUBLE PRECISION array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
/* Modified. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
/* Modified. */
/* RESULT - DOUBLE PRECISION array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -26: NWORK too small. */
/* If ZLATMR, CLATMS, or CLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then ZHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by DLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--w1;
--w3;
--tau;
--work;
--rwork;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L250;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call ZGEHRD to compute H and U, do tests. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "ZGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + 1 + j * uu_dim1;
uu[i__4].r = 0., uu[i__4].i = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = i__ + j * u_dim1;
i__6 = i__ + j * h_dim1;
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = i__ + j * uu_dim1;
i__6 = i__ + j * h_dim1;
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = i__ + j * h_dim1;
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
zcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call ZHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (W3) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Compute Z = U' UZ */
zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[1], &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2),
d__2 = z_abs(&w3[j]);
temp1 = max(d__1,d__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[
i__5].i;
d__1 = temp2, d__2 = z_abs(&z__1);
temp2 = max(d__1,d__2);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectr_dim1;
i__6 = jj + k * evectl_dim1;
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectl_dim1;
i__6 = jj + k * evectr_dim1;
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call ZHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L220: */
}
zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call ZUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call ZUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
dlasum_("ZHS", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHS */
} /* zchkhs_ */
/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPO tests DPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)6, (ftnlen)6);
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from DPOTRF. */
if (info != izero) {
alaerh_(path, "DPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)6, (ftnlen)6);
dpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from DPOTRI. */
if (info != 0) {
alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)6, (ftnlen)
6);
dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from DPOTRS. */
if (info != 0) {
alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)6, (ftnlen)
6);
dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &iwork[1], &info);
/* Check error code from DPORFS. */
if (info != 0) {
alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)6, (ftnlen)6);
dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &iwork[1], &info);
/* Check error code from DPOCON. */
if (info != 0) {
alaerh_(path, "DPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPO */
} /* dchkpo_ */
/* Subroutine */ int alasvm_(char *type__, integer *nout, integer *nfail,
integer *nrun, integer *nerrs)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 drivers: \002,i6,\002 out of \002,"
"i6,\002 tests failed to pass the threshold\002)";
static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 drivers p"
"assed the \002,\002threshold (\002,i6,\002 tests run)\002)";
static char fmt_9997[] = "(14x,i6,\002 error messages recorded\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___3 = { 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 .. */
/* .. */
/* Purpose */
/* ======= */
/* ALASVM prints a summary of results from one of the -DRV- routines. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*3 */
/* The LAPACK path name. */
/* NOUT (input) INTEGER */
/* The unit number on which results are to be printed. */
/* NOUT >= 0. */
/* NFAIL (input) INTEGER */
/* The number of tests which did not pass the threshold ratio. */
/* NRUN (input) INTEGER */
/* The total number of tests. */
/* NERRS (input) INTEGER */
/* The number of error messages recorded. */
/* ===================================================================== */
/* .. Executable Statements .. */
if (*nfail > 0) {
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, type__, (ftnlen)3);
do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___2.ciunit = *nout;
s_wsfe(&io___2);
do_fio(&c__1, type__, (ftnlen)3);
do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
e_wsfe();
}
if (*nerrs > 0) {
io___3.ciunit = *nout;
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of ALASVM */
} /* alasvm_ */
/* Subroutine */ int hcore_(doublereal *coord, doublereal *h__, doublereal *w,
doublereal *wj, doublereal *wk, doublereal *enuclr)
{
/* Initialized data */
static integer icalcn = 0;
/* Format strings */
static char fmt_120[] = "(10f8.4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, i1, i2, j1, j2, ia, ib, ic;
static doublereal di[81] /* was [9][9] */;
static integer ja, jb, jc, ii, jj, ni, nj, kr;
static doublereal xf, yf, zf, e1b[10], e2a[10];
static integer im1, io1, jo1;
static doublereal wjd[100], wkd[100];
static integer kro;
static doublereal half;
static integer ione;
static doublereal fnuc, enuc;
extern doublereal reada_(char *, integer *, ftnlen);
static logical debug, fldon, first;
extern /* Subroutine */ int h1elec_(integer *, integer *, doublereal *,
doublereal *, doublereal *), addhcr_(doublereal *), addnuc_(
doublereal *);
static doublereal fldcon, hterme, cutoff;
extern /* Subroutine */ int rotate_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *), vecprt_(doublereal *, integer *);
static char tmpkey[241];
extern /* Subroutine */ int solrot_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, "(/10X,'THE ELECTRIC FIELD IS',3F10.5)"
, 0 };
static cilist io___12 = { 0, 6, 0, "(10X,'IN 8*A.U. (8*27.21/0.529 VOLTS"
"/ANGSTROM)',/)", 0 };
static cilist io___44 = { 0, 6, 0, "(//10X,'ONE-ELECTRON MATRIX FROM HCO"
"RE')", 0 };
static cilist io___45 = { 0, 6, 0, "(//10X,'TWO-ELECTRON MATRIX IN HCORE"
"'/)", 0 };
static cilist io___46 = { 0, 6, 0, fmt_120, 0 };
static cilist io___47 = { 0, 6, 0, "(//10X,'TWO-ELECTRON J MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___48 = { 0, 6, 0, fmt_120, 0 };
static cilist io___49 = { 0, 6, 0, "(//10X,'TWO-ELECTRON K MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___50 = { 0, 6, 0, fmt_120, 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* COSMO change */
/* end of COSMO change */
/* *********************************************************************** */
/* HCORE GENERATES THE ONE-ELECTRON MATRIX AND TWO ELECTRON INTEGRALS */
/* FOR A GIVEN MOLECULE WHOSE GEOMETRY IS DEFINED IN CARTESIAN */
/* COORDINATES. */
/* ON INPUT COORD = COORDINATES OF THE MOLECULE. */
/* ON OUTPUT H = ONE-ELECTRON MATRIX. */
/* W = TWO-ELECTRON INTEGRALS. */
/* ENUCLR = NUCLEAR ENERGY */
/* *********************************************************************** */
/* Parameter adjustments */
--wk;
--wj;
--w;
--h__;
coord -= 4;
/* Function Body */
first = icalcn != numcal_1.numcal;
icalcn = numcal_1.numcal;
if (first) {
ione = 1;
cutoff = 1e10;
if (euler_1.id != 0) {
cutoff = 60.;
}
if (euler_1.id != 0) {
ione = 0;
}
debug = i_indx(keywrd_1.keywrd, "HCORE", (ftnlen)241, (ftnlen)5) != 0;
/* ****************************************************************** */
xf = 0.;
yf = 0.;
zf = 0.;
s_copy(tmpkey, keywrd_1.keywrd, (ftnlen)241, (ftnlen)241);
i__ = i_indx(tmpkey, " FIELD(", (ftnlen)241, (ftnlen)7);
if (i__ == 0) {
goto L6;
}
/* ERASE ALL TEXT FROM TMPKEY EXCEPT FIELD DATA */
s_copy(tmpkey, " ", i__, (ftnlen)1);
i__1 = i_indx(tmpkey, ")", (ftnlen)241, (ftnlen)1) - 1;
s_copy(tmpkey + i__1, " ", 241 - i__1, (ftnlen)1);
/* READ IN THE EFFECTIVE FIELD IN X,Y,Z COORDINATES */
xf = reada_(tmpkey, &i__, (ftnlen)241);
i__ = i_indx(tmpkey, ",", (ftnlen)241, (ftnlen)1);
if (i__ == 0) {
goto L5;
}
*(unsigned char *)&tmpkey[i__ - 1] = ' ';
yf = reada_(tmpkey, &i__, (ftnlen)241);
i__ = i_indx(tmpkey, ",", (ftnlen)241, (ftnlen)1);
if (i__ == 0) {
goto L5;
}
*(unsigned char *)&tmpkey[i__ - 1] = ' ';
zf = reada_(tmpkey, &i__, (ftnlen)241);
L5:
s_wsfe(&io___11);
do_fio(&c__1, (char *)&xf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zf, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsfe(&io___12);
e_wsfe();
L6:
field_1.efield[0] = xf;
field_1.efield[1] = yf;
field_1.efield[2] = zf;
/* ********************************************************************** */
}
fldon = FALSE_;
if (field_1.efield[0] != 0. || field_1.efield[1] != 0. || field_1.efield[
2] != 0.) {
fldcon = 51.4257;
fldon = TRUE_;
}
i__1 = molkst_1.norbs * (molkst_1.norbs + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
h__[i__] = 0.;
}
*enuclr = 0.;
kr = 1;
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
ia = molkst_1.nfirst[i__ - 1];
ib = molkst_1.nlast[i__ - 1];
ic = molkst_1.nmidle[i__ - 1];
ni = molkst_1.nat[i__ - 1];
/* FIRST WE FILL THE DIAGONALS, AND OFF-DIAGONALS ON THE SAME ATOM */
i__2 = ib;
for (i1 = ia; i1 <= i__2; ++i1) {
i2 = i1 * (i1 - 1) / 2 + ia - 1;
i__3 = i1;
for (j1 = ia; j1 <= i__3; ++j1) {
++i2;
h__[i2] = 0.;
if (fldon) {
io1 = i1 - ia;
jo1 = j1 - ia;
if (jo1 == 0 && io1 == 1) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[0] * fldcon;
h__[i2] = hterme;
}
if (jo1 == 0 && io1 == 2) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[1] * fldcon;
h__[i2] = hterme;
}
if (jo1 == 0 && io1 == 3) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[2] * fldcon;
h__[i2] = hterme;
}
}
/* L20: */
}
h__[i2] = molorb_1.uspd[i1 - 1];
if (fldon) {
fnuc = -(field_1.efield[0] * coord[i__ * 3 + 1] +
field_1.efield[1] * coord[i__ * 3 + 2] +
field_1.efield[2] * coord[i__ * 3 + 3]) * fldcon;
h__[i2] += fnuc;
}
/* L30: */
}
/* FILL THE ATOM-OTHER ATOM ONE-ELECTRON MATRIX<PSI(LAMBDA)|PSI(SIGMA)> */
im1 = i__ - ione;
i__2 = im1;
for (j = 1; j <= i__2; ++j) {
half = 1.;
if (i__ == j) {
half = .5;
}
ja = molkst_1.nfirst[j - 1];
jb = molkst_1.nlast[j - 1];
jc = molkst_1.nmidle[j - 1];
nj = molkst_1.nat[j - 1];
h1elec_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], di);
i2 = 0;
i__3 = ib;
for (i1 = ia; i1 <= i__3; ++i1) {
ii = i1 * (i1 - 1) / 2 + ja - 1;
++i2;
j2 = 0;
jj = min(i1,jb);
i__4 = jj;
for (j1 = ja; j1 <= i__4; ++j1) {
++ii;
++j2;
/* L40: */
h__[ii] += di[i2 + j2 * 9 - 10];
}
}
/* CALCULATE THE TWO-ELECTRON INTEGRALS, W; THE ELECTRON NUCLEAR TERMS */
/* E1B AND E2A; AND THE NUCLEAR-NUCLEAR TERM ENUC. */
if (euler_1.id == 0) {
rotate_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], &w[
kr], &kr, e1b, e2a, &enuc, &cutoff);
} else {
kro = kr;
solrot_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], wjd,
wkd, &kr, e1b, e2a, &enuc, &cutoff);
jj = 0;
i__4 = kr - 1;
for (ii = kro; ii <= i__4; ++ii) {
++jj;
wj[ii] = wjd[jj - 1];
/* L50: */
wk[ii] = wkd[jj - 1];
}
}
*enuclr += enuc;
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM I. */
i2 = 0;
i__4 = ic;
for (i1 = ia; i1 <= i__4; ++i1) {
ii = i1 * (i1 - 1) / 2 + ia - 1;
i__3 = i1;
for (j1 = ia; j1 <= i__3; ++j1) {
++ii;
++i2;
/* L60: */
h__[ii] += e1b[i2 - 1] * half;
}
}
i__3 = ib;
for (i1 = ic + 1; i1 <= i__3; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L70: */
h__[ii] += e1b[0] * half;
}
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM J. */
i2 = 0;
i__3 = jc;
for (i1 = ja; i1 <= i__3; ++i1) {
ii = i1 * (i1 - 1) / 2 + ja - 1;
i__4 = i1;
for (j1 = ja; j1 <= i__4; ++j1) {
++ii;
++i2;
/* L80: */
h__[ii] += e2a[i2 - 1] * half;
}
}
i__4 = jb;
for (i1 = jc + 1; i1 <= i__4; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L90: */
h__[ii] += e2a[0] * half;
}
/* L100: */
}
/* L110: */
}
/* COSMO change */
/* A. KLAMT 16.7.91 */
if (iseps_1.useps) {
/* The following routine adds the dielectric correction for the electron-core */
/* interaction to the diagonal elements of H */
addhcr_(&h__[1]);
/* In the following routine the dielectric correction to the core-core- */
/* interaction is added to ENUCLR */
addnuc_(enuclr);
}
/* end of COSMO change */
if (! debug) {
return 0;
}
s_wsfe(&io___44);
e_wsfe();
vecprt_(&h__[1], &molkst_1.norbs);
j = min(400,kr);
if (euler_1.id == 0) {
s_wsfe(&io___45);
e_wsfe();
s_wsfe(&io___46);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&w[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
s_wsfe(&io___47);
e_wsfe();
s_wsfe(&io___48);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&wj[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___49);
e_wsfe();
s_wsfe(&io___50);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&wk[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
return 0;
} /* hcore_ */
/* Subroutine */ int xerrwv_(char *msg, integer *nmes, integer *nerr, integer
*level, integer *ni, integer *i1, integer *i2, integer *nr,
doublereal *r1, doublereal *r2, ftnlen msg_len)
{
/* Format strings */
static char fmt_10[] = "(1x,80a1)";
static char fmt_20[] = "(6x,\002In above message, I1 =\002,i10)";
static char fmt_30[] = "(6x,\002In above message, I1 =\002,i10,3x,\002I"
"2 =\002,i10)";
static char fmt_40[] = "(6x,\002In above message, R1 =\002,e21.13)";
static char fmt_50[] = "(6x,\002In above, R1 =\002,e21.13,3x,\002R2 "
"=\002,e21.13)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer i__, lunit, mesflg;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, fmt_10, 0 };
static cilist io___7 = { 0, 0, 0, fmt_20, 0 };
static cilist io___8 = { 0, 0, 0, fmt_30, 0 };
static cilist io___9 = { 0, 0, 0, fmt_40, 0 };
static cilist io___10 = { 0, 0, 0, fmt_50, 0 };
/* ----------------------------------------------------------------------- */
/* Subroutine XERRWV, as given here, constitutes a simplified version of */
/* the SLATEC error handling package. */
/* Written by A. C. Hindmarsh and P. N. Brown at LLNL. */
/* Modified 1/8/90 by Clement Ulrich at LLNL. */
/* Version of 8 January, 1990. */
/* This version is in double precision. */
/* All arguments are input arguments. */
/* MSG = The message (character array). */
/* NMES = The length of MSG (number of characters). */
/* NERR = The error number (not used). */
/* LEVEL = The error level.. */
/* 0 or 1 means recoverable (control returns to caller). */
/* 2 means fatal (run is aborted--see note below). */
/* NI = Number of integers (0, 1, or 2) to be printed with message. */
/* I1,I2 = Integers to be printed, depending on NI. */
/* NR = Number of reals (0, 1, or 2) to be printed with message. */
/* R1,R2 = Reals to be printed, depending on NR. */
/* Note.. this routine is compatible with ANSI-77; however the */
/* following assumptions may not be valid for some machines: */
/* 1. The argument MSG is assumed to be of type CHARACTER, and */
/* the message is printed with a format of (1X,80A1). */
/* 2. The message is assumed to take only one line. */
/* Multi-line messages are generated by repeated calls. */
/* 3. If LEVEL = 2, control passes to the statement STOP */
/* to abort the run. For a different run-abort command, */
/* change the statement following statement 100 at the end. */
/* 4. R1 and R2 are assumed to be in double precision and are printed */
/* in E21.13 format. */
/* 5. The logical unit number 6 is standard output. */
/* For a different default logical unit number, change the assignment */
/* statement for LUNIT below. */
/* ----------------------------------------------------------------------- */
/* Subroutines called by XERRWV.. None */
/* Function routines called by XERRWV.. None */
/* ----------------------------------------------------------------------- */
/* Define message print flag and logical unit number. ------------------- */
/* Parameter adjustments */
--msg;
/* Function Body */
mesflg = 1;
lunit = 6;
if(mesflg == 0) {
goto L100;
}
/* Write the message. --------------------------------------------------- */
io___5.ciunit = lunit;
s_wsfe(&io___5);
i__1 = *nmes;
for(i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, msg + i__, (ftnlen)1);
}
e_wsfe();
if(*ni == 1) {
io___7.ciunit = lunit;
s_wsfe(&io___7);
do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
e_wsfe();
}
if(*ni == 2) {
io___8.ciunit = lunit;
s_wsfe(&io___8);
do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer));
e_wsfe();
}
if(*nr == 1) {
io___9.ciunit = lunit;
s_wsfe(&io___9);
do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
e_wsfe();
}
if(*nr == 2) {
io___10.ciunit = lunit;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* Abort the run if LEVEL = 2. ------------------------------------------ */
L100:
if(*level != 2) {
return 0;
}
s_stop("", (ftnlen)0);
/* ----------------------- End of Subroutine XERRWV ---------------------- */
return 0;
} /* xerrwv_ */
/* Subroutine */ int newuob_(integer *n, integer *npt, doublereal *x,
doublereal *rhobeg, doublereal *rhoend, integer *iprint, integer *
maxfun, doublereal *xbase, doublereal *xopt, doublereal *xnew,
doublereal *xpt, doublereal *fval, doublereal *gq, doublereal *hq,
doublereal *pq, doublereal *bmat, doublereal *zmat, integer *ndim,
doublereal *d__, doublereal *vlag, doublereal *w, S_fp calfun)
{
/* Format strings */
static char fmt_320[] = "(/4x,\002Return from NEWUOA because CALFUN has "
"been\002,\002 called MAXFUN times.\002)";
static char fmt_330[] = "(/4x,\002Function number\002,i6,\002 F =\002"
",1pd18.10,\002 The corresponding X is:\002/(2x,5d15.6))";
static char fmt_370[] = "(/4x,\002Return from NEWUOA because a trus"
"t\002,\002 region step has failed to reduce Q.\002)";
static char fmt_500[] = "(5x)";
static char fmt_510[] = "(/4x,\002New RHO =\002,1pd11.4,5x,\002Number o"
"f\002,\002 function values =\002,i6)";
static char fmt_520[] = "(4x,\002Least value of F =\002,1pd23.15,9x,\002"
"The corresponding X is:\002/(2x,5d15.6))";
static char fmt_550[] = "(/4x,\002At the return from NEWUOA\002,5x,\002N"
"umber of function values =\002,i6)";
/* System generated locals */
integer xpt_dim1, xpt_offset, bmat_dim1, bmat_offset, zmat_dim1,
zmat_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static doublereal f;
static integer i__, j, k, ih, nf, nh, ip, jp;
static doublereal dx;
static integer np, nfm;
static doublereal one;
static integer idz;
static doublereal dsq, rho;
static integer ipt, jpt;
static doublereal sum, fbeg, diff, half, beta;
static integer nfmm;
static doublereal gisq;
static integer knew;
static doublereal temp, suma, sumb, fopt, bsum, gqsq;
static integer kopt, nptm;
static doublereal zero, xipt, xjpt, sumz, diffa, diffb, diffc, hdiag,
alpha, delta, recip, reciq, fsave;
static integer ksave, nfsav, itemp;
static doublereal dnorm, ratio, dstep, tenth, vquad;
static integer ktemp;
static doublereal tempq;
static integer itest;
static doublereal rhosq;
extern /* Subroutine */ int biglag_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), bigden_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), update_(integer *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal detrat, crvmin;
static integer nftest;
static doublereal distsq;
extern /* Subroutine */ int trsapp_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal xoptsq;
/* Fortran I/O blocks */
static cilist io___55 = { 0, 6, 0, fmt_320, 0 };
static cilist io___56 = { 0, 6, 0, fmt_330, 0 };
static cilist io___61 = { 0, 6, 0, fmt_370, 0 };
static cilist io___68 = { 0, 6, 0, fmt_500, 0 };
static cilist io___69 = { 0, 6, 0, fmt_510, 0 };
static cilist io___70 = { 0, 6, 0, fmt_520, 0 };
static cilist io___71 = { 0, 6, 0, fmt_550, 0 };
static cilist io___72 = { 0, 6, 0, fmt_520, 0 };
/* The arguments N, NPT, X, RHOBEG, RHOEND, IPRINT and MAXFUN are identical */
/* to the corresponding arguments in SUBROUTINE NEWUOA. */
/* XBASE will hold a shift of origin that should reduce the contributions */
/* from rounding errors to values of the model and Lagrange functions. */
/* XOPT will be set to the displacement from XBASE of the vector of */
/* variables that provides the least calculated F so far. */
/* XNEW will be set to the displacement from XBASE of the vector of */
/* variables for the current calculation of F. */
/* XPT will contain the interpolation point coordinates relative to XBASE. */
/* FVAL will hold the values of F at the interpolation points. */
/* GQ will hold the gradient of the quadratic model at XBASE. */
/* HQ will hold the explicit second derivatives of the quadratic model. */
/* PQ will contain the parameters of the implicit second derivatives of */
/* the quadratic model. */
/* BMAT will hold the last N columns of H. */
/* ZMAT will hold the factorization of the leading NPT by NPT submatrix of */
/* H, this factorization being ZMAT times Diag(DZ) times ZMAT^T, where */
/* the elements of DZ are plus or minus one, as specified by IDZ. */
/* NDIM is the first dimension of BMAT and has the value NPT+N. */
/* D is reserved for trial steps from XOPT. */
/* VLAG will contain the values of the Lagrange functions at a new point X. */
/* They are part of a product that requires VLAG to be of length NDIM. */
/* The array W will be used for working space. Its length must be at least */
/* 10*NDIM = 10*(NPT+N). */
/* Set some constants. */
/* Parameter adjustments */
zmat_dim1 = *npt;
zmat_offset = 1 + zmat_dim1;
zmat -= zmat_offset;
xpt_dim1 = *npt;
xpt_offset = 1 + xpt_dim1;
xpt -= xpt_offset;
--x;
--xbase;
--xopt;
--xnew;
--fval;
--gq;
--hq;
--pq;
bmat_dim1 = *ndim;
bmat_offset = 1 + bmat_dim1;
bmat -= bmat_offset;
--d__;
--vlag;
--w;
/* Function Body */
half = .5;
one = 1.;
tenth = .1;
zero = 0.;
np = *n + 1;
nh = *n * np / 2;
nptm = *npt - np;
nftest = max(*maxfun,1);
/* Set the initial elements of XPT, BMAT, HQ, PQ and ZMAT to zero. */
i__1 = *n;
for(j = 1; j <= i__1; ++j) {
xbase[j] = x[j];
i__2 = *npt;
for(k = 1; k <= i__2; ++k) {
/* L10: */
xpt[k + j * xpt_dim1] = zero;
}
i__2 = *ndim;
for(i__ = 1; i__ <= i__2; ++i__) {
/* L20: */
bmat[i__ + j * bmat_dim1] = zero;
}
}
i__2 = nh;
for(ih = 1; ih <= i__2; ++ih) {
/* L30: */
hq[ih] = zero;
}
i__2 = *npt;
for(k = 1; k <= i__2; ++k) {
pq[k] = zero;
i__1 = nptm;
for(j = 1; j <= i__1; ++j) {
/* L40: */
zmat[k + j * zmat_dim1] = zero;
}
}
/* Begin the initialization procedure. NF becomes one more than the number */
/* of function values so far. The coordinates of the displacement of the */
/* next initial interpolation point from XBASE are set in XPT(NF,.). */
rhosq = *rhobeg * *rhobeg;
recip = one / rhosq;
reciq = sqrt(half) / rhosq;
nf = 0;
L50:
nfm = nf;
nfmm = nf - *n;
++nf;
if(nfm <= *n << 1) {
if(nfm >= 1 && nfm <= *n) {
xpt[nf + nfm * xpt_dim1] = *rhobeg;
} else if(nfm > *n) {
xpt[nf + nfmm * xpt_dim1] = -(*rhobeg);
}
} else {
itemp = (nfmm - 1) / *n;
jpt = nfm - itemp * *n - *n;
ipt = jpt + itemp;
if(ipt > *n) {
itemp = jpt;
jpt = ipt - *n;
ipt = itemp;
}
xipt = *rhobeg;
if(fval[ipt + np] < fval[ipt + 1]) {
xipt = -xipt;
}
xjpt = *rhobeg;
if(fval[jpt + np] < fval[jpt + 1]) {
xjpt = -xjpt;
}
xpt[nf + ipt * xpt_dim1] = xipt;
xpt[nf + jpt * xpt_dim1] = xjpt;
}
/* Calculate the next value of F, label 70 being reached immediately */
/* after this calculation. The least function value so far and its index */
/* are required. */
i__1 = *n;
for(j = 1; j <= i__1; ++j) {
/* L60: */
x[j] = xpt[nf + j * xpt_dim1] + xbase[j];
}
goto L310;
L70:
fval[nf] = f;
if(nf == 1) {
fbeg = f;
fopt = f;
kopt = 1;
} else if(f < fopt) {
fopt = f;
kopt = nf;
}
/* Set the nonzero initial elements of BMAT and the quadratic model in */
/* the cases when NF is at most 2*N+1. */
if(nfm <= *n << 1) {
if(nfm >= 1 && nfm <= *n) {
gq[nfm] = (f - fbeg) / *rhobeg;
if(*npt < nf + *n) {
bmat[nfm * bmat_dim1 + 1] = -one / *rhobeg;
bmat[nf + nfm * bmat_dim1] = one / *rhobeg;
bmat[*npt + nfm + nfm * bmat_dim1] = -half * rhosq;
}
} else if(nfm > *n) {
bmat[nf - *n + nfmm * bmat_dim1] = half / *rhobeg;
bmat[nf + nfmm * bmat_dim1] = -half / *rhobeg;
zmat[nfmm * zmat_dim1 + 1] = -reciq - reciq;
zmat[nf - *n + nfmm * zmat_dim1] = reciq;
zmat[nf + nfmm * zmat_dim1] = reciq;
ih = nfmm * (nfmm + 1) / 2;
temp = (fbeg - f) / *rhobeg;
hq[ih] = (gq[nfmm] - temp) / *rhobeg;
gq[nfmm] = half * (gq[nfmm] + temp);
}
/* Set the off-diagonal second derivatives of the Lagrange functions and */
/* the initial quadratic model. */
} else {
ih = ipt * (ipt - 1) / 2 + jpt;
if(xipt < zero) {
ipt += *n;
}
if(xjpt < zero) {
jpt += *n;
}
zmat[nfmm * zmat_dim1 + 1] = recip;
zmat[nf + nfmm * zmat_dim1] = recip;
zmat[ipt + 1 + nfmm * zmat_dim1] = -recip;
zmat[jpt + 1 + nfmm * zmat_dim1] = -recip;
hq[ih] = (fbeg - fval[ipt + 1] - fval[jpt + 1] + f) / (xipt * xjpt);
}
if(nf < *npt) {
goto L50;
}
/* Begin the iterative procedure, because the initial model is complete. */
rho = *rhobeg;
delta = rho;
idz = 1;
diffa = zero;
diffb = zero;
itest = 0;
xoptsq = zero;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
xopt[i__] = xpt[kopt + i__ * xpt_dim1];
/* L80: */
/* Computing 2nd power */
d__1 = xopt[i__];
xoptsq += d__1 * d__1;
}
L90:
nfsav = nf;
/* Generate the next trust region step and test its length. Set KNEW */
/* to -1 if the purpose of the next F will be to improve the model. */
L100:
knew = 0;
trsapp_(n, npt, &xopt[1], &xpt[xpt_offset], &gq[1], &hq[1], &pq[1], &
delta, &d__[1], &w[1], &w[np], &w[np + *n], &w[np + (*n << 1)], &
crvmin);
dsq = zero;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
/* L110: */
/* Computing 2nd power */
d__1 = d__[i__];
dsq += d__1 * d__1;
}
/* Computing MIN */
d__1 = delta, d__2 = sqrt(dsq);
dnorm = min(d__1,d__2);
if(dnorm < half * rho) {
knew = -1;
delta = tenth * delta;
ratio = -1.;
if(delta <= rho * 1.5) {
delta = rho;
}
if(nf <= nfsav + 2) {
goto L460;
}
temp = crvmin * .125 * rho * rho;
/* Computing MAX */
d__1 = max(diffa,diffb);
if(temp <= max(d__1,diffc)) {
goto L460;
}
goto L490;
}
/* Shift XBASE if XOPT may be too far from XBASE. First make the changes */
/* to BMAT that do not depend on ZMAT. */
L120:
if(dsq <= xoptsq * .001) {
tempq = xoptsq * .25;
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
sum = zero;
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
/* L130: */
sum += xpt[k + i__ * xpt_dim1] * xopt[i__];
}
temp = pq[k] * sum;
sum -= half * xoptsq;
w[*npt + k] = sum;
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
gq[i__] += temp * xpt[k + i__ * xpt_dim1];
xpt[k + i__ * xpt_dim1] -= half * xopt[i__];
vlag[i__] = bmat[k + i__ * bmat_dim1];
w[i__] = sum * xpt[k + i__ * xpt_dim1] + tempq * xopt[i__];
ip = *npt + i__;
i__3 = i__;
for(j = 1; j <= i__3; ++j) {
/* L140: */
bmat[ip + j * bmat_dim1] = bmat[ip + j * bmat_dim1] +
vlag[i__] * w[j] + w[i__] * vlag[j];
}
}
}
/* Then the revisions of BMAT that depend on ZMAT are calculated. */
i__3 = nptm;
for(k = 1; k <= i__3; ++k) {
sumz = zero;
i__2 = *npt;
for(i__ = 1; i__ <= i__2; ++i__) {
sumz += zmat[i__ + k * zmat_dim1];
/* L150: */
w[i__] = w[*npt + i__] * zmat[i__ + k * zmat_dim1];
}
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
sum = tempq * sumz * xopt[j];
i__1 = *npt;
for(i__ = 1; i__ <= i__1; ++i__) {
/* L160: */
sum += w[i__] * xpt[i__ + j * xpt_dim1];
}
vlag[j] = sum;
if(k < idz) {
sum = -sum;
}
i__1 = *npt;
for(i__ = 1; i__ <= i__1; ++i__) {
/* L170: */
bmat[i__ + j * bmat_dim1] += sum * zmat[i__ + k *
zmat_dim1];
}
}
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
ip = i__ + *npt;
temp = vlag[i__];
if(k < idz) {
temp = -temp;
}
i__2 = i__;
for(j = 1; j <= i__2; ++j) {
/* L180: */
bmat[ip + j * bmat_dim1] += temp * vlag[j];
}
}
}
/* The following instructions complete the shift of XBASE, including */
/* the changes to the parameters of the quadratic model. */
ih = 0;
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
w[j] = zero;
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
w[j] += pq[k] * xpt[k + j * xpt_dim1];
/* L190: */
xpt[k + j * xpt_dim1] -= half * xopt[j];
}
i__1 = j;
for(i__ = 1; i__ <= i__1; ++i__) {
++ih;
if(i__ < j) {
gq[j] += hq[ih] * xopt[i__];
}
gq[i__] += hq[ih] * xopt[j];
hq[ih] = hq[ih] + w[i__] * xopt[j] + xopt[i__] * w[j];
/* L200: */
bmat[*npt + i__ + j * bmat_dim1] = bmat[*npt + j + i__ *
bmat_dim1];
}
}
i__1 = *n;
for(j = 1; j <= i__1; ++j) {
xbase[j] += xopt[j];
/* L210: */
xopt[j] = zero;
}
xoptsq = zero;
}
/* Pick the model step if KNEW is positive. A different choice of D */
/* may be made later, if the choice of D by BIGLAG causes substantial */
/* cancellation in DENOM. */
if(knew > 0) {
biglag_(n, npt, &xopt[1], &xpt[xpt_offset], &bmat[bmat_offset], &zmat[
zmat_offset], &idz, ndim, &knew, &dstep, &d__[1], &alpha, &
vlag[1], &vlag[*npt + 1], &w[1], &w[np], &w[np + *n]);
}
/* Calculate VLAG and BETA for the current choice of D. The first NPT */
/* components of W_check will be held in W. */
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
suma = zero;
sumb = zero;
sum = zero;
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
suma += xpt[k + j * xpt_dim1] * d__[j];
sumb += xpt[k + j * xpt_dim1] * xopt[j];
/* L220: */
sum += bmat[k + j * bmat_dim1] * d__[j];
}
w[k] = suma * (half * suma + sumb);
/* L230: */
vlag[k] = sum;
}
beta = zero;
i__1 = nptm;
for(k = 1; k <= i__1; ++k) {
sum = zero;
i__2 = *npt;
for(i__ = 1; i__ <= i__2; ++i__) {
/* L240: */
sum += zmat[i__ + k * zmat_dim1] * w[i__];
}
if(k < idz) {
beta += sum * sum;
sum = -sum;
} else {
beta -= sum * sum;
}
i__2 = *npt;
for(i__ = 1; i__ <= i__2; ++i__) {
/* L250: */
vlag[i__] += sum * zmat[i__ + k * zmat_dim1];
}
}
bsum = zero;
dx = zero;
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
sum = zero;
i__1 = *npt;
for(i__ = 1; i__ <= i__1; ++i__) {
/* L260: */
sum += w[i__] * bmat[i__ + j * bmat_dim1];
}
bsum += sum * d__[j];
jp = *npt + j;
i__1 = *n;
for(k = 1; k <= i__1; ++k) {
/* L270: */
sum += bmat[jp + k * bmat_dim1] * d__[k];
}
vlag[jp] = sum;
bsum += sum * d__[j];
/* L280: */
dx += d__[j] * xopt[j];
}
beta = dx * dx + dsq * (xoptsq + dx + dx + half * dsq) + beta - bsum;
vlag[kopt] += one;
/* If KNEW is positive and if the cancellation in DENOM is unacceptable, */
/* then BIGDEN calculates an alternative model step, XNEW being used for */
/* working space. */
if(knew > 0) {
/* Computing 2nd power */
d__1 = vlag[knew];
temp = one + alpha * beta / (d__1 * d__1);
if(abs(temp) <= .8) {
bigden_(n, npt, &xopt[1], &xpt[xpt_offset], &bmat[bmat_offset], &
zmat[zmat_offset], &idz, ndim, &kopt, &knew, &d__[1], &w[
1], &vlag[1], &beta, &xnew[1], &w[*ndim + 1], &w[*ndim *
6 + 1]);
}
}
/* Calculate the next value of the objective function. */
L290:
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
xnew[i__] = xopt[i__] + d__[i__];
/* L300: */
x[i__] = xbase[i__] + xnew[i__];
}
++nf;
L310:
if(nf > nftest) {
--nf;
if(*iprint > 0) {
s_wsfe(&io___55);
e_wsfe();
}
goto L530;
}
(*calfun)(n, &x[1], &f);
if(*iprint == 3) {
s_wsfe(&io___56);
do_fio(&c__1, (char *)&nf, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&f, (ftnlen)sizeof(doublereal));
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
if(nf <= *npt) {
goto L70;
}
if(knew == -1) {
goto L530;
}
/* Use the quadratic model to predict the change in F due to the step D, */
/* and set DIFF to the error of this prediction. */
vquad = zero;
ih = 0;
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
vquad += d__[j] * gq[j];
i__1 = j;
for(i__ = 1; i__ <= i__1; ++i__) {
++ih;
temp = d__[i__] * xnew[j] + d__[j] * xopt[i__];
if(i__ == j) {
temp = half * temp;
}
/* L340: */
vquad += temp * hq[ih];
}
}
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
/* L350: */
vquad += pq[k] * w[k];
}
diff = f - fopt - vquad;
diffc = diffb;
diffb = diffa;
diffa = abs(diff);
if(dnorm > rho) {
nfsav = nf;
}
/* Update FOPT and XOPT if the new F is the least value of the objective */
/* function so far. The branch when KNEW is positive occurs if D is not */
/* a trust region step. */
fsave = fopt;
if(f < fopt) {
fopt = f;
xoptsq = zero;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
xopt[i__] = xnew[i__];
/* L360: */
/* Computing 2nd power */
d__1 = xopt[i__];
xoptsq += d__1 * d__1;
}
}
ksave = knew;
if(knew > 0) {
goto L410;
}
/* Pick the next value of DELTA after a trust region step. */
if(vquad >= zero) {
if(*iprint > 0) {
s_wsfe(&io___61);
e_wsfe();
}
goto L530;
}
ratio = (f - fsave) / vquad;
if(ratio <= tenth) {
delta = half * dnorm;
} else if(ratio <= .7) {
/* Computing MAX */
d__1 = half * delta;
delta = max(d__1,dnorm);
} else {
/* Computing MAX */
d__1 = half * delta, d__2 = dnorm + dnorm;
delta = max(d__1,d__2);
}
if(delta <= rho * 1.5) {
delta = rho;
}
/* Set KNEW to the index of the next interpolation point to be deleted. */
/* Computing MAX */
d__2 = tenth * delta;
/* Computing 2nd power */
d__1 = max(d__2,rho);
rhosq = d__1 * d__1;
ktemp = 0;
detrat = zero;
if(f >= fsave) {
ktemp = kopt;
detrat = one;
}
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
hdiag = zero;
i__2 = nptm;
for(j = 1; j <= i__2; ++j) {
temp = one;
if(j < idz) {
temp = -one;
}
/* L380: */
/* Computing 2nd power */
d__1 = zmat[k + j * zmat_dim1];
hdiag += temp * (d__1 * d__1);
}
/* Computing 2nd power */
d__2 = vlag[k];
temp = (d__1 = beta * hdiag + d__2 * d__2, abs(d__1));
distsq = zero;
i__2 = *n;
for(j = 1; j <= i__2; ++j) {
/* L390: */
/* Computing 2nd power */
d__1 = xpt[k + j * xpt_dim1] - xopt[j];
distsq += d__1 * d__1;
}
if(distsq > rhosq) {
/* Computing 3rd power */
d__1 = distsq / rhosq;
temp *= d__1 * (d__1 * d__1);
}
if(temp > detrat && k != ktemp) {
detrat = temp;
knew = k;
}
/* L400: */
}
if(knew == 0) {
goto L460;
}
/* Update BMAT, ZMAT and IDZ, so that the KNEW-th interpolation point */
/* can be moved. Begin the updating of the quadratic model, starting */
/* with the explicit second derivative term. */
L410:
update_(n, npt, &bmat[bmat_offset], &zmat[zmat_offset], &idz, ndim, &vlag[
1], &beta, &knew, &w[1]);
fval[knew] = f;
ih = 0;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
temp = pq[knew] * xpt[knew + i__ * xpt_dim1];
i__2 = i__;
for(j = 1; j <= i__2; ++j) {
++ih;
/* L420: */
hq[ih] += temp * xpt[knew + j * xpt_dim1];
}
}
pq[knew] = zero;
/* Update the other second derivative parameters, and then the gradient */
/* vector of the model. Also include the new interpolation point. */
i__2 = nptm;
for(j = 1; j <= i__2; ++j) {
temp = diff * zmat[knew + j * zmat_dim1];
if(j < idz) {
temp = -temp;
}
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
/* L440: */
pq[k] += temp * zmat[k + j * zmat_dim1];
}
}
gqsq = zero;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
gq[i__] += diff * bmat[knew + i__ * bmat_dim1];
/* Computing 2nd power */
d__1 = gq[i__];
gqsq += d__1 * d__1;
/* L450: */
xpt[knew + i__ * xpt_dim1] = xnew[i__];
}
/* If a trust region step makes a small change to the objective function, */
/* then calculate the gradient of the least Frobenius norm interpolant at */
/* XBASE, and store it in W, using VLAG for a vector of right hand sides. */
if(ksave == 0 && delta == rho) {
if(abs(ratio) > .01) {
itest = 0;
} else {
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
/* L700: */
vlag[k] = fval[k] - fval[kopt];
}
gisq = zero;
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
sum = zero;
i__2 = *npt;
for(k = 1; k <= i__2; ++k) {
/* L710: */
sum += bmat[k + i__ * bmat_dim1] * vlag[k];
}
gisq += sum * sum;
/* L720: */
w[i__] = sum;
}
/* Test whether to replace the new quadratic model by the least Frobenius */
/* norm interpolant, making the replacement if the test is satisfied. */
++itest;
if(gqsq < gisq * 100.) {
itest = 0;
}
if(itest >= 3) {
i__1 = *n;
for(i__ = 1; i__ <= i__1; ++i__) {
/* L730: */
gq[i__] = w[i__];
}
i__1 = nh;
for(ih = 1; ih <= i__1; ++ih) {
/* L740: */
hq[ih] = zero;
}
i__1 = nptm;
for(j = 1; j <= i__1; ++j) {
w[j] = zero;
i__2 = *npt;
for(k = 1; k <= i__2; ++k) {
/* L750: */
w[j] += vlag[k] * zmat[k + j * zmat_dim1];
}
/* L760: */
if(j < idz) {
w[j] = -w[j];
}
}
i__1 = *npt;
for(k = 1; k <= i__1; ++k) {
pq[k] = zero;
i__2 = nptm;
for(j = 1; j <= i__2; ++j) {
/* L770: */
pq[k] += zmat[k + j * zmat_dim1] * w[j];
}
}
itest = 0;
}
}
}
if(f < fsave) {
kopt = knew;
}
/* If a trust region step has provided a sufficient decrease in F, then */
/* branch for another trust region calculation. The case KSAVE>0 occurs */
/* when the new function value was calculated by a model step. */
if(f <= fsave + tenth * vquad) {
goto L100;
}
if(ksave > 0) {
goto L100;
}
/* Alternatively, find out if the interpolation points are close enough */
/* to the best point so far. */
knew = 0;
L460:
distsq = delta * 4. * delta;
i__2 = *npt;
for(k = 1; k <= i__2; ++k) {
sum = zero;
i__1 = *n;
for(j = 1; j <= i__1; ++j) {
/* L470: */
/* Computing 2nd power */
d__1 = xpt[k + j * xpt_dim1] - xopt[j];
sum += d__1 * d__1;
}
if(sum > distsq) {
knew = k;
distsq = sum;
}
/* L480: */
}
/* If KNEW is positive, then set DSTEP, and branch back for the next */
/* iteration, which will generate a "model step". */
if(knew > 0) {
/* Computing MAX */
/* Computing MIN */
d__2 = tenth * sqrt(distsq), d__3 = half * delta;
d__1 = min(d__2,d__3);
dstep = max(d__1,rho);
dsq = dstep * dstep;
goto L120;
}
if(ratio > zero) {
goto L100;
}
if(max(delta,dnorm) > rho) {
goto L100;
}
/* The calculations with the current value of RHO are complete. Pick the */
/* next values of RHO and DELTA. */
L490:
if(rho > *rhoend) {
delta = half * rho;
ratio = rho / *rhoend;
if(ratio <= 16.) {
rho = *rhoend;
} else if(ratio <= 250.) {
rho = sqrt(ratio) * *rhoend;
} else {
rho = tenth * rho;
}
delta = max(delta,rho);
if(*iprint >= 2) {
if(*iprint >= 3) {
s_wsfe(&io___68);
e_wsfe();
}
s_wsfe(&io___69);
do_fio(&c__1, (char *)&rho, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&nf, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___70);
do_fio(&c__1, (char *)&fopt, (ftnlen)sizeof(doublereal));
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
d__1 = xbase[i__] + xopt[i__];
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
goto L90;
}
/* Return from the calculation, after another Newton-Raphson step, if */
/* it is too short to have been tried before. */
if(knew == -1) {
goto L290;
}
L530:
if(fopt <= f) {
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
/* L540: */
x[i__] = xbase[i__] + xopt[i__];
}
f = fopt;
}
if(*iprint >= 1) {
s_wsfe(&io___71);
do_fio(&c__1, (char *)&nf, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___72);
do_fio(&c__1, (char *)&f, (ftnlen)sizeof(doublereal));
i__2 = *n;
for(i__ = 1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
return 0;
} /* newuob_ */
/* Subroutine */ int cmout_(integer *lout, integer *m, integer *n, complex *a,
integer *lda, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Initialized data */
static char icol[1*3] = "C" "o" "l";
/* Format strings */
static char fmt_9999[] = "(/1x,a/1x,a)";
static char fmt_9998[] = "(11x,4(9x,3a1,i4,9x))";
static char fmt_9994[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9984[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9997[] = "(10x,4(11x,3a1,i4,11x))";
static char fmt_9993[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e12.5,\002,\002,e12.5,\002) \002))";
static char fmt_9983[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e12.5,\002,\002,e12.5,\002) \002))";
static char fmt_9996[] = "(10x,3(13x,3a1,i4,13x))";
static char fmt_9992[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e14.7,\002,\002,e14.7,\002) \002))";
static char fmt_9982[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e14.7,\002,\002,e14.7,\002) \002))";
static char fmt_9995[] = "(12x,2(18x,3a1,i4,18x))";
static char fmt_9991[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e20.13,\002,\002,e20.13,\002)\002))";
static char fmt_9974[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,4(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9964[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9954[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9944[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e10.3,\002,\002,e10.3,\002) \002))";
static char fmt_9973[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,e12.5,\002,\002,e12.5,\002) \002))";
static char fmt_9963[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e12.5,\002,\002,e12.5,\002) \002))";
static char fmt_9953[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e12.5,\002,\002,e12.5,\002) \002))";
static char fmt_9972[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,3(\002("
"\002,e14.7,\002,\002,e14.7,\002) \002))";
static char fmt_9962[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e14.7,\002,\002,e14.7,\002) \002))";
static char fmt_9952[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e14.7,\002,\002,e14.7,\002) \002))";
static char fmt_9971[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,2(\002("
"\002,e20.13,\002,\002,e20.13,\002) \002))";
static char fmt_9961[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,1(\002("
"\002,e20.13,\002,\002,e20.13,\002) \002))";
static char fmt_9990[] = "(1x,\002 \002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, k1, k2, lll;
static char line[80];
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9984, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9983, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9982, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9974, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9964, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9954, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9944, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9973, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9963, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9953, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9972, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9962, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9952, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9971, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9961, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9990, 0 };
/* ... */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* ... */
/* ... SPECIFICATIONS INTRINSICS */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___5.ciunit = *lout;
s_wsfe(&io___5);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*m <= 0 || *n <= 0 || *lda <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___9.ciunit = *lout;
s_wsfe(&io___9);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else {
io___12.ciunit = *lout;
s_wsfe(&io___12);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L30: */
}
/* L40: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___13.ciunit = *lout;
s_wsfe(&io___13);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___14.ciunit = *lout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else {
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L50: */
}
/* L60: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___16.ciunit = *lout;
s_wsfe(&io___16);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 != *n) {
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else {
io___18.ciunit = *lout;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L70: */
}
/* L80: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; ++k1) {
io___19.ciunit = *lout;
s_wsfe(&io___19);
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___20.ciunit = *lout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&a[i__ + k1 * a_dim1], (ftnlen)
sizeof(real));
e_wsfe();
/* L90: */
}
/* L100: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___21.ciunit = *lout;
s_wsfe(&io___21);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 3 <= *n) {
io___22.ciunit = *lout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 3 - *n == 1) {
io___23.ciunit = *lout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 3 - *n == 2) {
io___24.ciunit = *lout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 3 - *n == 3) {
io___25.ciunit = *lout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L110: */
}
/* L120: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___26.ciunit = *lout;
s_wsfe(&io___26);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 2 <= *n) {
io___27.ciunit = *lout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___28.ciunit = *lout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___29.ciunit = *lout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L130: */
}
/* L140: */
}
} else if (ndigit <= 8) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___30.ciunit = *lout;
s_wsfe(&io___30);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 2 <= *n) {
io___31.ciunit = *lout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 2 - *n == 1) {
io___32.ciunit = *lout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else if (k1 + 2 - *n == 2) {
io___33.ciunit = *lout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L150: */
}
/* L160: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___34.ciunit = *lout;
s_wsfe(&io___34);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (k1 + 1 <= *n) {
io___35.ciunit = *lout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
} else {
io___36.ciunit = *lout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__2, (char *)&a[i__ + j * a_dim1], (
ftnlen)sizeof(real));
}
e_wsfe();
}
/* L170: */
}
/* L180: */
}
}
}
io___37.ciunit = *lout;
s_wsfe(&io___37);
e_wsfe();
/* ======================================================== */
/* FORMAT FOR 72 COLUMN */
/* ======================================================== */
/* DISPLAY 4 SIGNIFICANT DIGITS */
/* DISPLAY 6 SIGNIFICANT DIGITS */
/* DISPLAY 8 SIGNIFICANT DIGITS */
/* DISPLAY 13 SIGNIFICANT DIGITS */
/* ======================================================== */
/* FORMAT FOR 132 COLUMN */
/* ======================================================== */
/* DISPLAY 4 SIGNIFICANT DIGIT */
/* DISPLAY 6 SIGNIFICANT DIGIT */
/* DISPLAY 8 SIGNIFICANT DIGIT */
/* DISPLAY 13 SIGNIFICANT DIGIT */
return 0;
} /* cmout_ */
/* $Procedure PROMPT ( Prompt a user for a string ) */
/* Subroutine */ int prompt_(char *prmpt, char *string, ftnlen prmpt_len,
ftnlen string_len)
{
/* System generated locals */
integer i__1, i__2;
cilist ci__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsfe(cilist *), e_rsfe(void), i_len(char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen)
, setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
/* $ Abstract */
/* This routine prompts a user for keyboard input. */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for input. */
/* STRING O The response typed by a user. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position and describes the input that */
/* the user is expected to enter. The string PRMPT should */
/* be relatively short, i.e., 50 or fewer characters, so */
/* that a response may be typed on the line where the */
/* prompt appears. */
/* All characters (including trailing blanks) in PRMPT */
/* are considered significant and will be displayed. */
/* $ Detailed_Output */
/* STRING is a character string that contains the string */
/* entered by the user. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This subroutine uses discovery check-in so that it may be called */
/* after an error has occurred. */
/* 1) If the attempt to write the prompt to the standard output */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(WRITEFAILED) will be signalled. */
/* 2) If the attempt to read the response from the standard input */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(READFAILED) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request information */
/* from a program user. At a high level, it frees you from the */
/* peculiarities of a particular implementation of FORTRAN cursor */
/* control. */
/* $ Examples */
/* Suppose you wanted to ask a user to input an answer to */
/* a question such as "Do you want to try again? (Y/N) " */
/* and leave the cursor at the end of the question as shown here: */
/* Do you want to try again? (Y/N) _ */
/* (The underscore indicates the cursor position). */
/* The following line of code will do what you want. */
/* CALL PROMPT ( 'Do you want to try again? (Y/N) ', ANSWER ) */
/* $ Restrictions */
/* This routine is environment specific. Standard FORTRAN does not */
/* provide for user control of cursor position after write */
/* statements. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 3.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 3.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 3.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 3.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.0.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* - SPICELIB Version 1.0.0, 15-OCT-1992 (WLT) */
/* -& */
/* $ Index_Entries */
/* Prompt for keyboard input */
/* Prompt for input with a user supplied message */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* -& */
/* Local variables */
/* The following code should be used in the following environments: */
/* VAX/FORTRAN, IBM-PC/Lahey Fortran, MacIntosh/Language Systems */
/* Fortran */
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(1H ,A,$)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, prmpt, prmpt_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
/* If none of the write statements above works on a particular */
/* unsupported platform, read on... */
/* Although, this isn't really what you want, if you need to port */
/* this quickly to an environment that does not support the format */
/* statement in any of the cases above, you can comment out the */
/* write statement above and un-comment the write statement below. */
/* In this way you can get a program working quickly in the new */
/* environment while you figure out how to control cursor */
/* positioning. */
/* WRITE (*,*, IOSTAT=IOSTAT ) PRMPT */
/* Check for a write error. It's not likely, but the standard output */
/* can be redirected. Better safe than confused later. */
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to write a prompt to the"
" standard output device, possibly because standard output ha"
"s been redirected to a file. There is not much that can be d"
"one about this if it happens. We do not try to determine whe"
"ther standard output has been redirected, so be sure that th"
"ere are sufficient resources available for the operation bei"
"ng performed.", (ftnlen)372);
sigerr_("SPICE(WRITEFAILED)", (ftnlen)18);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
/* Now that we've written out the prompt and there was no error, we */
/* can read in the response. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = 5;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, string, string_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to retrieve a reply to t"
"he prompt \"#\". A possible cause is that you have exhauste"
"d the input buffer while attempting to type your response. "
"It may help if you limit your response to # or fewer charact"
"ers. ", (ftnlen)242);
errch_("#", prmpt, (ftnlen)1, prmpt_len);
/* Computing MIN */
i__2 = i_len(string, string_len);
i__1 = min(i__2,131);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(READFAILED)", (ftnlen)17);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
return 0;
} /* prompt_ */
/* Subroutine */ int sprtbg_(char *subnam, integer *ntypes, logical *dotype,
integer *nsizes, integer *nn, integer *inparm, char *pnames, integer *
nparms, integer *np1, integer *np2, integer *np3, integer *np4,
integer *np5, integer *np6, real *ops, integer *ldo1, integer *ldo2,
real *times, integer *ldt1, integer *ldt2, real *rwork, logical *
llwork, integer *nout, ftnlen subnam_len, ftnlen pnames_len)
{
/* Format strings */
static char fmt_9999[] = "(///\002 ****** Results for \002,a,\002 *****"
"*\002)";
static char fmt_9995[] = "(5x,:\002with \002,4(a,\002=\002,i5,:\002, "
"\002)/10x,2(a,\002=\002,i5,:\002, \002))";
static char fmt_9980[] = "(\002( 5X, : I5 , 6( \002,i2,\002X, I5, : ) "
")\002)";
static char fmt_9981[] = "(\002( 5X, : 'line ' , 6( \002,i2,\002X, A, : "
") )\002)";
static char fmt_9996[] = "(/\002 *** Time in seconds ***\002)";
static char fmt_9997[] = "(/\002 *** Number of floating-point operations"
" ***\002)";
static char fmt_9998[] = "(/\002 *** Speed in megaflops ***\002)";
/* System generated locals */
integer ops_dim1, ops_dim2, ops_offset, times_dim1, times_dim2,
times_offset, i__1, i__2, i__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_len(char *, ftnlen), s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer ipar, i__, j, ipada, ipadi, iline, iinfo;
static logical ltemp;
static integer jp, js, jt;
static char frmata[40], frmati[40];
static integer ilines;
extern doublereal smflop_(real *, real *, integer *);
extern /* Subroutine */ int sprtbs_(char *, char *, integer *, logical *,
integer *, integer *, integer *, logical *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___7 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9995, 0 };
static icilist io___15 = { 0, frmati, 0, fmt_9980, 40, 1 };
static icilist io___18 = { 0, frmata, 0, fmt_9981, 40, 1 };
static cilist io___19 = { 0, 0, 0, frmata, 0 };
static cilist io___20 = { 0, 0, 0, frmati, 0 };
static cilist io___21 = { 0, 0, 0, frmati, 0 };
static cilist io___22 = { 0, 0, 0, frmati, 0 };
static cilist io___23 = { 0, 0, 0, frmati, 0 };
static cilist io___24 = { 0, 0, 0, frmati, 0 };
static cilist io___25 = { 0, 0, 0, frmati, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
#define times_ref(a_1,a_2,a_3) times[((a_3)*times_dim2 + (a_2))*\
times_dim1 + a_1]
#define pnames_ref(a_0,a_1) &pnames[(a_1)*pnames_len + a_0]
#define ops_ref(a_1,a_2,a_3) ops[((a_3)*ops_dim2 + (a_2))*ops_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
February 29, 1992
Purpose
=======
SPRTBG prints out timing information for the eigenvalue routines.
The table has NTYPES block rows and NSIZES columns, with NPARMS
individual rows in each block row. There are INPARM quantities
which depend on rows (currently, INPARM <= 4).
Arguments (none are modified)
=========
SUBNAM - CHARACTER*(*)
The label for the output.
NTYPES - INTEGER
The number of values of DOTYPE, and also the
number of sets of rows of the table.
DOTYPE - LOGICAL array of dimension( NTYPES )
If DOTYPE(j) is .TRUE., then block row j (which includes
data from RESLTS( i, j, k ), for all i and k) will be
printed. If DOTYPE(j) is .FALSE., then block row j will
not be printed.
NSIZES - INTEGER
The number of values of NN, and also the
number of columns of the table.
NN - INTEGER array of dimension( NSIZES )
The values of N used to label each column.
INPARM - INTEGER
The number of different parameters which are functions of
the row number. At the moment, INPARM <= 4.
PNAMES - CHARACTER*(*) array of dimension( INPARM )
The label for the columns.
NPARMS - INTEGER
The number of values for each "parameter", i.e., the
number of rows for each value of DOTYPE.
NP1 - INTEGER array of dimension( NPARMS )
The first quantity which depends on row number.
NP2 - INTEGER array of dimension( NPARMS )
The second quantity which depends on row number.
NP3 - INTEGER array of dimension( NPARMS )
The third quantity which depends on row number.
NP4 - INTEGER array of dimension( NPARMS )
The fourth quantity which depends on row number.
NP5 - INTEGER array of dimension( NPARMS )
The fifth quantity which depends on row number.
NP6 - INTEGER array of dimension( NPARMS )
The sixth quantity which depends on row number.
OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
The operation counts. The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDO1 - INTEGER
The first dimension of OPS. It must be at least
min( 1, NPARMS ).
LDO2 - INTEGER
The second dimension of OPS. It must be at least
min( 1, NTYPES ).
TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
The times (in seconds). The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDT1 - INTEGER
The first dimension of RESLTS. It must be at least
min( 1, NPARMS ).
LDT2 - INTEGER
The second dimension of RESLTS. It must be at least
min( 1, NTYPES ).
RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
Real workspace.
Modified.
LLWORK - LOGICAL array of dimension( NPARMS )
Logical workspace. It is used to turn on or off specific
lines in the output. If LLWORK(i) is .TRUE., then row i
(which includes data from OPS(i,j,k) or TIMES(i,j,k) for
all j and k) will be printed. If LLWORK(i) is
.FALSE., then row i will not be printed.
Modified.
NOUT - INTEGER
The output unit number on which the table
is to be printed. If NOUT <= 0, no output is printed.
=====================================================================
First line
Parameter adjustments */
--dotype;
--nn;
pnames -= pnames_len;
--llwork;
--np1;
--np2;
--np3;
--np4;
--np5;
--np6;
ops_dim1 = *ldo1;
ops_dim2 = *ldo2;
ops_offset = 1 + ops_dim1 * (1 + ops_dim2 * 1);
ops -= ops_offset;
times_dim1 = *ldt1;
times_dim2 = *ldt2;
times_offset = 1 + times_dim1 * (1 + times_dim2 * 1);
times -= times_offset;
--rwork;
/* Function Body */
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, subnam, subnam_len);
e_wsfe();
/* Set up which lines are to be printed. */
llwork[1] = TRUE_;
ilines = 1;
i__1 = *nparms;
for (ipar = 2; ipar <= i__1; ++ipar) {
llwork[ipar] = TRUE_;
i__2 = ipar - 1;
for (j = 1; j <= i__2; ++j) {
ltemp = FALSE_;
if (*inparm >= 1 && np1[j] != np1[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 2 && np2[j] != np2[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 3 && np3[j] != np3[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 4 && np4[j] != np4[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 5 && np5[j] != np5[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 6 && np6[j] != np6[ipar]) {
ltemp = TRUE_;
}
if (! ltemp) {
llwork[ipar] = FALSE_;
}
/* L10: */
}
if (llwork[ipar]) {
++ilines;
}
/* L20: */
}
if (ilines == 1) {
if (*inparm == 1) {
io___6.ciunit = *nout;
s_wsfe(&io___6);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___7.ciunit = *nout;
s_wsfe(&io___7);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___8.ciunit = *nout;
s_wsfe(&io___8);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 6), pnames_len);
do_fio(&c__1, (char *)&np6[1], (ftnlen)sizeof(integer));
e_wsfe();
}
} else {
iline = 0;
/* Compute output format statement.
Computing MAX */
i__1 = i_len(pnames_ref(0, 1), pnames_len) - 3;
ipadi = max(i__1,1);
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ipadi, (ftnlen)sizeof(integer));
e_wsfi();
ipada = ipadi + 5 - i_len(pnames_ref(0, 1), pnames_len);
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ipada, (ftnlen)sizeof(integer));
e_wsfi();
io___19.ciunit = *nout;
s_wsfe(&io___19);
i__1 = min(6,*inparm);
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, pnames_ref(0, j), pnames_len);
}
e_wsfe();
i__1 = *nparms;
for (j = 1; j <= i__1; ++j) {
if (llwork[j]) {
++iline;
if (*inparm == 1) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np6[j], (ftnlen)sizeof(integer));
e_wsfe();
}
}
/* L30: */
}
}
/* Execution Times */
io___26.ciunit = *nout;
s_wsfe(&io___26);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], ×[times_offset], ldt1, ldt2, nout, (ftnlen)4, (ftnlen)2);
/* Operation Counts */
io___27.ciunit = *nout;
s_wsfe(&io___27);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &ops[ops_offset], ldo1, ldo2, nout, (ftnlen)4, (ftnlen)2);
/* Megaflop Rates */
iinfo = 0;
i__1 = *nsizes;
for (js = 1; js <= i__1; ++js) {
i__2 = *ntypes;
for (jt = 1; jt <= i__2; ++jt) {
if (dotype[jt]) {
i__3 = *nparms;
for (jp = 1; jp <= i__3; ++jp) {
i__ = jp + *nparms * (jt - 1 + *ntypes * (js - 1));
rwork[i__] = smflop_(&ops_ref(jp, jt, js), ×_ref(jp,
jt, js), &iinfo);
/* L40: */
}
}
/* L50: */
}
/* L60: */
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &rwork[1], nparms, ntypes, nout, (ftnlen)4, (ftnlen)2);
/* Format statements for generating format statements.
9981 generates a string 21+2+11=34 characters long.
9980 generates a string 16+2+12=30 characters long. */
return 0;
/* End of SPRTBG */
} /* sprtbg_ */
/* Subroutine */ int cdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, 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[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
real r__1, r__2;
char ch__1[2];
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer k1, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode, koff, imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
real rcondc;
real rcondi;
real rcondo, anormi;
real ainvnm;
logical trfcon;
real anormo;
real result[6];
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVGT tests CGTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) 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*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
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) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with 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)32, (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 L130;
}
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 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], a[i__3].i = 0.f;
if (n > 1) {
a[1].r = z__[2], a[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1], a[i__3].i = 0.f;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = n - 1 + izero;
a[i__3].r = z__[1], a[i__3].i = 0.f;
i__3 = izero;
a[i__3].r = z__[2], a[i__3].i = 0.f;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1] = a[i__3].r;
i__3 = n;
a[i__3].r = 0.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2] = a[1].r;
a[1].r = 0.f, a[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0] = a[i__3].r;
i__3 = (n << 1) - 1;
z__[1] = a[i__3].r;
i__3 = n * 3 - 2;
a[i__3].r = 0.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;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by CGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = clangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* 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_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* 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;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
&iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
clagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test CGTSV --- */
/* Solve the system using Gaussian elimination with */
/* partial pivoting. */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)32, (ftnlen)
6);
cgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from CGTSV . */
if (info != izero) {
alaerh_(path, "CGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
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]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test CGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
af[i__4].r = 0.f, af[i__4].i = 0.f;
/* L90: */
}
}
claset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using CGTSVX. */
s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)32, (ftnlen)6);
cgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
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);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
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]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
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[3]);
nt = 5;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGT */
} /* cdrvgt_ */
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static integer nd[10] = { 120,54,49,32,4,3,2 };
/* Format strings */
static char fmt_1001[] = "(\0020N\002,i5,\002 RFFTF \002,e10.3,\002 RFF"
"TB \002,e10.3,\002 RFFTFB \002,e10.3,\002 SINT \002,e10.3,"
"\002 SINTFB \002,e10.3,\002 COST \002,e10.3/7x,\002 COSTFB "
"\002,e10.3,\002 SINQF \002,e10.3,\002 SINQB \002,e10.3,\002 SI"
"NQFB \002,e10.3,\002 COSQF \002,e10.3,\002 COSQB \002,e10.3/7x,"
"\002 COSQFB \002,e10.3,\002 DEZF \002,e10.3,\002 DEZB \002,e"
"10.3,\002 DEZFB \002,e10.3,\002 CFFTF \002,e10.3,\002 CFFTB "
" \002,e10.3/7x,\002 CFFTFB \002,e10.3)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double sqrt(doublereal), sin(doublereal), cos(doublereal);
integer pow_ii(integer *, integer *);
double atan(doublereal), z_abs(doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublereal a[100], b[100];
integer i__, j, k, n;
doublereal w[2000], x[200], y[200], ah[100], bh[100], cf, fn, dt, pi;
doublecomplex cx[200], cy[200];
doublereal xh[200];
integer nz, nm1, np1, ns2;
doublereal arg, tfn, tpi;
integer nns;
doublereal sum, arg1, arg2;
integer ns2m;
doublereal sum1, sum2, dcfb;
integer ifac[64], modn;
doublereal rftb, rftf;
extern /* Subroutine */ void cost(integer *, doublereal *, doublereal *,
integer *), sint(integer *, doublereal *, doublereal *, integer *
);
doublereal dezb1, dezf1, sqrt2;
extern /* Subroutine */ void cfftb(integer *, doublecomplex *, doublereal
*, integer *), cfftf(integer *, doublecomplex *, doublereal *,
integer *);
doublereal dezfb;
extern /* Subroutine */ void cffti(integer *, doublereal *, integer *),
rfftb(integer *, doublereal *, doublereal *, integer *);
doublereal rftfb;
extern /* Subroutine */ void rfftf(integer *, doublereal *, doublereal *,
integer *), cosqb(integer *, doublereal *, doublereal *, integer
*), rffti(integer *, doublereal *, integer *), cosqf(integer *,
doublereal *, doublereal *, integer *), sinqb(integer *,
doublereal *, doublereal *, integer *), cosqi(integer *,
doublereal *, integer *), sinqf(integer *, doublereal *,
doublereal *, integer *), costi(integer *, doublereal *, integer
*);
doublereal azero;
extern /* Subroutine */ void sinqi(integer *, doublereal *, integer *),
sinti(integer *, doublereal *, integer *);
doublereal costt, sintt, dcfftb, dcfftf, cosqfb, costfb;
extern /* Subroutine */ void ezfftb(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal sinqfb;
extern /* Subroutine */ void ezfftf(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal sintfb;
extern /* Subroutine */ void ezffti(integer *, doublereal *, integer *);
doublereal azeroh, cosqbt, cosqft, sinqbt, sinqft;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, fmt_1001, 0 };
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* VERSION 4 APRIL 1985 */
/* A TEST DRIVER FOR */
/* A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER */
/* TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES */
/* BY */
/* PAUL N SWARZTRAUBER */
/* NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER,COLORADO 80307 */
/* WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* THIS PROGRAM TESTS THE PACKAGE OF FAST FOURIER */
/* TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND */
/* CERTIAN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW. */
/* 1. RFFTI INITIALIZE RFFTF AND RFFTB */
/* 2. RFFTF FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE */
/* 3. RFFTB BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY */
/* 4. EZFFTI INITIALIZE EZFFTF AND EZFFTB */
/* 5. EZFFTF A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM */
/* 6. EZFFTB A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM */
/* 7. SINTI INITIALIZE SINT */
/* 8. SINT SINE TRANSFORM OF A REAL ODD SEQUENCE */
/* 9. COSTI INITIALIZE COST */
/* 10. COST COSINE TRANSFORM OF A REAL EVEN SEQUENCE */
/* 11. SINQI INITIALIZE SINQF AND SINQB */
/* 12. SINQF FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS */
/* 13. SINQB UNNORMALIZED INVERSE OF SINQF */
/* 14. COSQI INITIALIZE COSQF AND COSQB */
/* 15. COSQF FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS */
/* 16. COSQB UNNORMALIZED INVERSE OF COSQF */
/* 17. CFFTI INITIALIZE CFFTF AND CFFTB */
/* 18. CFFTF FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE */
/* 19. CFFTB UNNORMALIZED INVERSE OF CFFTF */
sqrt2 = sqrt(2.0);
nns = 7;
i__1 = nns;
for (nz = 1; nz <= i__1; ++nz) {
n = nd[nz - 1];
modn = n % 2;
fn = (real) n;
tfn = fn + fn;
np1 = n + 1;
nm1 = n - 1;
i__2 = np1;
for (j = 1; j <= i__2; ++j) {
x[j - 1] = sin((real) j * sqrt2);
y[j - 1] = x[j - 1];
xh[j - 1] = x[j - 1];
/* L101: */
}
/* TEST SUBROUTINES RFFTI,RFFTF AND RFFTB */
rffti(&n, w, ifac);
pi = 3.141592653589793238462643383279502884197169399375108209749445923;
dt = (pi + pi) / fn;
ns2 = (n + 1) / 2;
if (ns2 < 2) {
goto L104;
}
i__2 = ns2;
for (k = 2; k <= i__2; ++k) {
sum1 = 0.0;
sum2 = 0.0;
arg = (real) (k - 1) * dt;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
arg1 = (real) (i__ - 1) * arg;
sum1 += x[i__ - 1] * cos(arg1);
sum2 += x[i__ - 1] * sin(arg1);
/* L102: */
}
y[(k << 1) - 3] = sum1;
y[(k << 1) - 2] = -sum2;
/* L103: */
}
L104:
sum1 = 0.0;
sum2 = 0.0;
i__2 = nm1;
for (i__ = 1; i__ <= i__2; i__ += 2) {
sum1 += x[i__ - 1];
sum2 += x[i__];
/* L105: */
}
if (modn == 1) {
sum1 += x[n - 1];
}
y[0] = sum1 + sum2;
if (modn == 0) {
y[n - 1] = sum1 - sum2;
}
rfftf(&n, x, w, ifac);
rftf = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = rftf, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
rftf = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
/* L106: */
}
rftf /= fn;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
sum = x[0] * 0.5;
arg = (real) (i__ - 1) * dt;
if (ns2 < 2) {
goto L108;
}
i__3 = ns2;
for (k = 2; k <= i__3; ++k) {
arg1 = (real) (k - 1) * arg;
sum = sum + x[(k << 1) - 3] * cos(arg1) - x[(k << 1) - 2] *
sin(arg1);
/* L107: */
}
L108:
if (modn == 0) {
i__3 = i__ - 1;
sum += (real) pow_ii(&c_n1, &i__3) * 0.5 * x[n - 1];
}
y[i__ - 1] = sum + sum;
/* L109: */
}
rfftb(&n, x, w, ifac);
rftb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = rftb, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
rftb = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
y[i__ - 1] = xh[i__ - 1];
/* L110: */
}
rfftb(&n, y, w, ifac);
rfftf(&n, y, w, ifac);
cf = 1.0 / fn;
rftfb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = rftfb, d__3 = (d__1 = cf * y[i__ - 1] - x[i__ - 1], abs(
d__1));
rftfb = max(d__2,d__3);
/* L111: */
}
/* TEST SUBROUTINES SINTI AND SINT */
dt = pi / fn;
i__2 = nm1;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ - 1] = xh[i__ - 1];
/* L112: */
}
i__2 = nm1;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__ - 1] = 0.0;
arg1 = (real) i__ * dt;
i__3 = nm1;
for (k = 1; k <= i__3; ++k) {
y[i__ - 1] += x[k - 1] * sin((real) k * arg1);
/* L113: */
}
y[i__ - 1] += y[i__ - 1];
/* L114: */
}
sinti(&nm1, w, ifac);
sint(&nm1, x, w, ifac);
cf = 0.5 / fn;
sintt = 0.0;
i__2 = nm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = sintt, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
sintt = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
y[i__ - 1] = x[i__ - 1];
/* L115: */
}
sintt = cf * sintt;
sint(&nm1, x, w, ifac);
sint(&nm1, x, w, ifac);
sintfb = 0.0;
i__2 = nm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = sintfb, d__3 = (d__1 = cf * x[i__ - 1] - y[i__ - 1], abs(
d__1));
sintfb = max(d__2,d__3);
/* L116: */
}
/* TEST SUBROUTINES COSTI AND COST */
i__2 = np1;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ - 1] = xh[i__ - 1];
/* L117: */
}
i__2 = np1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + 1;
y[i__ - 1] = (x[0] + (real) pow_ii(&c_n1, &i__3) * x[n]) * 0.5;
arg = (real) (i__ - 1) * dt;
i__3 = n;
for (k = 2; k <= i__3; ++k) {
y[i__ - 1] += x[k - 1] * cos((real) (k - 1) * arg);
/* L118: */
}
y[i__ - 1] += y[i__ - 1];
/* L119: */
}
costi(&np1, w, ifac);
cost(&np1, x, w, ifac);
costt = 0.0;
i__2 = np1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = costt, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
costt = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
y[i__ - 1] = xh[i__ - 1];
/* L120: */
}
costt = cf * costt;
cost(&np1, x, w, ifac);
cost(&np1, x, w, ifac);
costfb = 0.0;
i__2 = np1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = costfb, d__3 = (d__1 = cf * x[i__ - 1] - y[i__ - 1], abs(
d__1));
costfb = max(d__2,d__3);
/* L121: */
}
/* TEST SUBROUTINES SINQI,SINQF AND SINQB */
cf = 0.25 / fn;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__ - 1] = xh[i__ - 1];
/* L122: */
}
dt = pi / (fn + fn);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ - 1] = 0.0;
arg = dt * (real) i__;
i__3 = n;
for (k = 1; k <= i__3; ++k) {
x[i__ - 1] += y[k - 1] * sin((real) (k + k - 1) * arg);
/* L123: */
}
x[i__ - 1] *= 4.0;
/* L124: */
}
sinqi(&n, w, ifac);
sinqb(&n, y, w, ifac);
sinqbt = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = sinqbt, d__3 = (d__1 = y[i__ - 1] - x[i__ - 1], abs(d__1));
sinqbt = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
/* L125: */
}
sinqbt = cf * sinqbt;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
arg = (real) (i__ + i__ - 1) * dt;
i__3 = i__ + 1;
y[i__ - 1] = (real) pow_ii(&c_n1, &i__3) * 0.5 * x[n - 1];
i__3 = nm1;
for (k = 1; k <= i__3; ++k) {
y[i__ - 1] += x[k - 1] * sin((real) k * arg);
/* L126: */
}
y[i__ - 1] += y[i__ - 1];
/* L127: */
}
sinqf(&n, x, w, ifac);
sinqft = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = sinqft, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
sinqft = max(d__2,d__3);
y[i__ - 1] = xh[i__ - 1];
x[i__ - 1] = xh[i__ - 1];
/* L128: */
}
sinqf(&n, y, w, ifac);
sinqb(&n, y, w, ifac);
sinqfb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = sinqfb, d__3 = (d__1 = cf * y[i__ - 1] - x[i__ - 1], abs(
d__1));
sinqfb = max(d__2,d__3);
/* L129: */
}
/* TEST SUBROUTINES COSQI,COSQF AND COSQB */
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__ - 1] = xh[i__ - 1];
/* L130: */
}
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ - 1] = 0.0;
arg = (real) (i__ - 1) * dt;
i__3 = n;
for (k = 1; k <= i__3; ++k) {
x[i__ - 1] += y[k - 1] * cos((real) (k + k - 1) * arg);
/* L131: */
}
x[i__ - 1] *= 4.0;
/* L132: */
}
cosqi(&n, w, ifac);
cosqb(&n, y, w, ifac);
cosqbt = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = cosqbt, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
cosqbt = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
/* L133: */
}
cosqbt = cf * cosqbt;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__ - 1] = x[0] * 0.5;
arg = (real) (i__ + i__ - 1) * dt;
i__3 = n;
for (k = 2; k <= i__3; ++k) {
y[i__ - 1] += x[k - 1] * cos((real) (k - 1) * arg);
/* L134: */
}
y[i__ - 1] += y[i__ - 1];
/* L135: */
}
cosqf(&n, x, w, ifac);
cosqft = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = cosqft, d__3 = (d__1 = y[i__ - 1] - x[i__ - 1], abs(d__1));
cosqft = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
y[i__ - 1] = xh[i__ - 1];
/* L136: */
}
cosqft = cf * cosqft;
cosqb(&n, x, w, ifac);
cosqf(&n, x, w, ifac);
cosqfb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = cosqfb, d__3 = (d__1 = cf * x[i__ - 1] - y[i__ - 1], abs(
d__1));
cosqfb = max(d__2,d__3);
/* L137: */
}
/* TEST PROGRAMS EZFFTI,EZFFTF,EZFFTB */
ezffti(&n, w, ifac);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__ - 1] = xh[i__ - 1];
/* L138: */
}
tpi = atan(1.0) * 8.0;
dt = tpi / (real) n;
ns2 = (n + 1) / 2;
cf = 2.0 / (real) n;
ns2m = ns2 - 1;
if (ns2m <= 0) {
goto L141;
}
i__2 = ns2m;
for (k = 1; k <= i__2; ++k) {
sum1 = 0.0;
sum2 = 0.0;
arg = (real) k * dt;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
arg1 = (real) (i__ - 1) * arg;
sum1 += x[i__ - 1] * cos(arg1);
sum2 += x[i__ - 1] * sin(arg1);
/* L139: */
}
a[k - 1] = cf * sum1;
b[k - 1] = cf * sum2;
/* L140: */
}
L141:
nm1 = n - 1;
sum1 = 0.0;
sum2 = 0.0;
i__2 = nm1;
for (i__ = 1; i__ <= i__2; i__ += 2) {
sum1 += x[i__ - 1];
sum2 += x[i__];
/* L142: */
}
if (modn == 1) {
sum1 += x[n - 1];
}
azero = cf * 0.5 * (sum1 + sum2);
if (modn == 0) {
a[ns2 - 1] = cf * 0.5 * (sum1 - sum2);
}
ezfftf(&n, x, &azeroh, ah, bh, w, ifac);
dezf1 = (d__1 = azeroh - azero, abs(d__1));
if (modn == 0) {
/* Computing MAX */
d__2 = dezf1, d__3 = (d__1 = a[ns2 - 1] - ah[ns2 - 1], abs(d__1));
dezf1 = max(d__2,d__3);
}
if (ns2m <= 0) {
goto L144;
}
i__2 = ns2m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__3 = dezf1, d__4 = (d__1 = ah[i__ - 1] - a[i__ - 1], abs(d__1)),
d__3 = max(d__3,d__4), d__4 = (d__2 = bh[i__ - 1] - b[
i__ - 1], abs(d__2));
dezf1 = max(d__3,d__4);
/* L143: */
}
L144:
ns2 = n / 2;
if (modn == 0) {
b[ns2 - 1] = 0.0;
}
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
sum = azero;
arg1 = (real) (i__ - 1) * dt;
i__3 = ns2;
for (k = 1; k <= i__3; ++k) {
arg2 = (real) k * arg1;
sum = sum + a[k - 1] * cos(arg2) + b[k - 1] * sin(arg2);
/* L145: */
}
x[i__ - 1] = sum;
/* L146: */
}
ezfftb(&n, y, &azero, a, b, w, ifac);
dezb1 = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = dezb1, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
dezb1 = max(d__2,d__3);
x[i__ - 1] = xh[i__ - 1];
/* L147: */
}
ezfftf(&n, x, &azero, a, b, w, ifac);
ezfftb(&n, y, &azero, a, b, w, ifac);
dezfb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = dezfb, d__3 = (d__1 = x[i__ - 1] - y[i__ - 1], abs(d__1));
dezfb = max(d__2,d__3);
/* L148: */
}
/* TEST CFFTI,CFFTF,CFFTB */
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ - 1;
d__1 = cos(sqrt2 * (real) i__);
d__2 = sin(sqrt2 * (real) (i__ * i__));
z__1.r = d__1, z__1.i = d__2;
cx[i__3].r = z__1.r, cx[i__3].i = z__1.i;
/* L149: */
}
dt = (pi + pi) / fn;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
arg1 = -((real) (i__ - 1)) * dt;
i__3 = i__ - 1;
cy[i__3].r = 0.0, cy[i__3].i = 0.0;
i__3 = n;
for (k = 1; k <= i__3; ++k) {
arg2 = (real) (k - 1) * arg1;
i__4 = i__ - 1;
i__5 = i__ - 1;
d__1 = cos(arg2);
d__2 = sin(arg2);
z__3.r = d__1, z__3.i = d__2;
i__6 = k - 1;
z__2.r = z__3.r * cx[i__6].r - z__3.i * cx[i__6].i, z__2.i =
z__3.r * cx[i__6].i + z__3.i * cx[i__6].r;
z__1.r = cy[i__5].r + z__2.r, z__1.i = cy[i__5].i + z__2.i;
cy[i__4].r = z__1.r, cy[i__4].i = z__1.i;
/* L150: */
}
/* L151: */
}
cffti(&n, w, ifac);
cfftf(&n, cx, w, ifac);
dcfftf = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ - 1;
i__4 = i__ - 1;
z__1.r = cx[i__3].r - cy[i__4].r, z__1.i = cx[i__3].i - cy[i__4]
.i;
d__1 = dcfftf, d__2 = z_abs(&z__1);
dcfftf = max(d__1,d__2);
i__3 = i__ - 1;
i__4 = i__ - 1;
z__1.r = cx[i__4].r / fn, z__1.i = cx[i__4].i / fn;
cx[i__3].r = z__1.r, cx[i__3].i = z__1.i;
/* L152: */
}
dcfftf /= fn;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
arg1 = (real) (i__ - 1) * dt;
i__3 = i__ - 1;
cy[i__3].r = 0.0, cy[i__3].i = 0.0;
i__3 = n;
for (k = 1; k <= i__3; ++k) {
arg2 = (real) (k - 1) * arg1;
i__4 = i__ - 1;
i__5 = i__ - 1;
d__1 = cos(arg2);
d__2 = sin(arg2);
z__3.r = d__1, z__3.i = d__2;
i__6 = k - 1;
z__2.r = z__3.r * cx[i__6].r - z__3.i * cx[i__6].i, z__2.i =
z__3.r * cx[i__6].i + z__3.i * cx[i__6].r;
z__1.r = cy[i__5].r + z__2.r, z__1.i = cy[i__5].i + z__2.i;
cy[i__4].r = z__1.r, cy[i__4].i = z__1.i;
/* L153: */
}
/* L154: */
}
cfftb(&n, cx, w, ifac);
dcfftb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ - 1;
i__4 = i__ - 1;
z__1.r = cx[i__3].r - cy[i__4].r, z__1.i = cx[i__3].i - cy[i__4]
.i;
d__1 = dcfftb, d__2 = z_abs(&z__1);
dcfftb = max(d__1,d__2);
i__3 = i__ - 1;
i__4 = i__ - 1;
cx[i__3].r = cy[i__4].r, cx[i__3].i = cy[i__4].i;
/* L155: */
}
cf = 1.0 / fn;
cfftf(&n, cx, w, ifac);
cfftb(&n, cx, w, ifac);
dcfb = 0.0;
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ - 1;
z__2.r = cf * cx[i__3].r, z__2.i = cf * cx[i__3].i;
i__4 = i__ - 1;
z__1.r = z__2.r - cy[i__4].r, z__1.i = z__2.i - cy[i__4].i;
d__1 = dcfb, d__2 = z_abs(&z__1);
dcfb = max(d__1,d__2);
/* L156: */
}
s_wsfe(&io___58);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&rftf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rftb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rftfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sintt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sintfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&costt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&costfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sinqft, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sinqbt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sinqfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cosqft, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cosqbt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cosqfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dezf1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dezb1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dezfb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dcfftf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dcfftb, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&dcfb, (ftnlen)sizeof(doublereal));
e_wsfe();
/* L157: */
}
return 0;
} /* MAIN__ */
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
doublecomplex a[2500] /* was [50][50] */, b[2500] /* was [50][
50] */, e[2500] /* was [50][50] */, f[2500] /* was [50][
50] */;
integer i__, j, m, n;
doublecomplex af[2500] /* was [50][50] */, bf[2500] /* was [50][
50] */, vl[2500] /* was [50][50] */, vr[2500] /* was [50][
50] */;
integer ihi, ilo;
doublereal eps;
doublecomplex vlf[2500] /* was [50][50] */;
integer knt;
doublecomplex vrf[2500] /* was [50][50] */;
integer info, lmax[4];
doublereal rmax, vmax;
doublecomplex work[2500] /* was [50][50] */;
integer ninfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
doublereal rwork[300];
extern doublereal dlamch_(char *);
doublereal lscale[50];
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal rscale[50];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGK tests ZGGBAK, a routine for backward balancing of */
/* a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L50: */
}
++knt;
anorm = zlange_("M", &n, &n, a, &c__50, rwork);
bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
&info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of ZGGBAK */
/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/* where tilde(A) denotes the transformed matrix. */
zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 50 - 51;
i__4 = i__ + j * 50 - 51;
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGK */
} /* zchkgk_ */
/* Subroutine */ int zdrvrf1_(integer *nout, integer *nn, integer *nval,
doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
arf, doublereal *work)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "C";
static char norms[1*4] = "M" "1" "I" "F";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
"ing ZLANHF ***\002)";
static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
"'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
"i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
",\002', NORM='\002,a1,\002', test=\002,g12.5)";
static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
"outine passed the \002,\002threshold (\002,i5,\002 tests run)"
"\002)";
static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
" of \002,i5,\002 tests failed to pass the threshold\002)";
static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
",\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__, j, n, iin, iit;
doublereal eps;
integer info;
char norm[1], uplo[1];
integer nrun, nfail;
doublereal large;
integer iseed[4];
char cform[1];
doublereal small;
integer iform;
doublereal norma;
integer inorm, iuplo, nerrs;
extern doublereal dlamch_(char *), zlanhe_(char *, char *,
integer *, doublecomplex *, integer *, doublereal *), zlanhf_(char *, char *, char *, integer *, doublecomplex
*, doublereal *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
doublereal result[1];
extern /* Subroutine */ int ztrttf_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal normarf;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, 0, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9994, 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 */
/* ======= */
/* ZDRVRF1 tests the LAPACK RFP routines: */
/* ZLANHF.F */
/* 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. */
/* 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. */
/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
/* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--work;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nfail = 0;
nerrs = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Precision");
small = dlamch_("Safe minimum");
large = 1. / small;
small = small * *lda * *lda;
large = large / *lda / *lda;
i__1 = *nn;
for (iin = 1; iin <= i__1; ++iin) {
n = nval[iin];
for (iit = 1; iit <= 3; ++iit) {
/* IIT = 1 : random matrix */
/* IIT = 2 : random matrix scaled near underflow */
/* IIT = 3 : random matrix scaled near overflow */
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
zlarnd_(&z__1, &c__4, iseed);
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
if (iit == 2) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = large * a[i__5].r, z__1.i = large * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
}
if (iit == 3) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = small * a[i__5].r, z__1.i = small * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Do first for CFORM = 'N', then for CFORM = 'C' */
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform
- 1];
s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)6);
ztrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
info);
/* Check error code from ZTRTTF */
if (info != 0) {
if (nfail == 0 && nerrs == 0) {
io___22.ciunit = *nout;
s_wsle(&io___22);
e_wsle();
io___23.ciunit = *nout;
s_wsfe(&io___23);
e_wsfe();
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
goto L100;
}
for (inorm = 1; inorm <= 4; ++inorm) {
/* Check all four norms: 'M', '1', 'I', 'F' */
*(unsigned char *)norm = *(unsigned char *)&norms[
inorm - 1];
normarf = zlanhf_(norm, cform, uplo, &n, &arf[1], &
work[1]);
norma = zlanhe_(norm, uplo, &n, &a[a_offset], lda, &
work[1]);
result[0] = (norma - normarf) / norma / eps;
++nrun;
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
io___30.ciunit = *nout;
s_wsle(&io___30);
e_wsle();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
}
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
integer));
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* Print a summary of the results. */
if (nfail == 0) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
if (nerrs != 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
do_fio(&c__1, "ZLANHF", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of ZDRVRF1 */
} /* zdrvrf1_ */
/* Subroutine */ int stimhr_(char *line, integer *nm, integer *mval, integer *
nn, integer *nval, integer *nnb, integer *nbval, integer *nxval,
integer *nlda, integer *ldaval, real *timmin, real *a, real *tau,
real *b, real *work, real *reslts, integer *ldr1, integer *ldr2,
integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*4] = "SGEHRD" "ORTHES" "SORGHR" "SORMHR";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "T";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"*** \002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9995[] = "(/5x,\002ILO = 1, IHI = N\002,/)";
static char fmt_9994[] = "(/5x,\002ILO = 1, IHI = M if SIDE = 'L'\002,/5"
"x,\002 = N if SIDE = 'R'\002)";
static char fmt_9996[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', TRANS"
" = '\002,a1,\002', \002,a1,\002 =\002,i6,/)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ilda;
static char side[1];
static integer info;
static char path[3];
static real time;
static integer isub, i__, m, n;
static char cname[6];
static integer iside, itoff, itran;
extern doublereal sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer i4, m1, n1;
static real s1, s2;
static integer ic;
extern /* Subroutine */ int sprtb3_(char *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb, im, in, lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), atimin_(char
*, char *, integer *, char *, logical *, integer *, integer *,
ftnlen, ftnlen, ftnlen), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *), xlaenv_(integer *,
integer *);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
extern /* Subroutine */ int stimmg_(integer *, integer *, integer *, real
*, integer *, integer *, integer *);
static logical timsub[4];
extern /* Subroutine */ int orthes_(integer *, integer *, integer *,
integer *, real *, real *), slatms_(integer *, integer *, char *,
integer *, char *, real *, integer *, real *, real *, integer *,
integer *, char *, real *, integer *, real *, integer *), sorghr_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, integer *), sprtbl_(char *,
char *, integer *, integer *, integer *, integer *, integer *,
real *, integer *, integer *, integer *, ftnlen, ftnlen), sormhr_(
char *, char *, integer *, integer *, integer *, integer *, real *
, integer *, real *, real *, integer *, real *, integer *,
integer *);
static integer lda, icl, inb, ihi, ilo;
static real ops;
static char lab1[1], lab2[1];
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___49 = { 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
=======
STIMHR times the LAPACK routines SGEHRD, SORGHR, and SORMHR and the
EISPACK routine ORTHES.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix size M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) REAL
The minimum time a subroutine will be timed.
A (workspace) REAL array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) REAL array, dimension (min(M,N))
B (workspace) REAL array, dimension (LDAMAX*NMAX)
WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
RESLTS (workspace) REAL array, dimension
(LDR1,LDR2,LDR3,4*NN+3)
The timing results for each subroutine over the relevant
values of M, (NB,NX), LDA, and N.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See CLATMS for further details.
COND REAL
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX REAL
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--nbval;
--nxval;
--ldaval;
--a;
--tau;
--b;
--work;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "HR", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__4, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L210;
}
/* Check that N <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L210;
}
/* Check that K <= LDA for SORMHR */
if (timsub[3]) {
atimck_(&c__3, cname, nn, &nval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, subnam_ref(0, 4), (ftnlen)6);
e_wsfe();
timsub[3] = FALSE_;
}
}
/* Do for each value of M: */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
ilo = 1;
ihi = m;
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = m * max(1,nb);
lw = max(i__4,i__5);
/* Generate a test matrix of size M by M. */
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
slatms_(&m, &m, "Uniform", iseed, "Nonsym", &tau[1], &c__3, &
c_b26, &c_b27, &m, &m, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[1] && inb == 1) {
/* ORTHES: Eispack reduction using orthogonal
transformations. */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = second_();
L10:
orthes_(&lda, &m, &c__1, &ihi, &a[1], &tau[1]);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L20:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L20;
}
time = (time - untime) / (real) ic;
ops = sopla_("SGEHRD", &m, &ilo, &ihi, &c__0, &nb);
reslts_ref(inb, im, ilda, 2) = smflop_(&ops, &time, &info)
;
}
if (timsub[0]) {
/* SGEHRD: Reduction to Hesenberg form */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = second_();
L30:
sgehrd_(&m, &ilo, &ihi, &a[1], &lda, &tau[1], &work[1], &
lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L30;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L40:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (real) ic;
ops = sopla_("SGEHRD", &m, &ilo, &ihi, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = smflop_(&ops, &time, &info)
;
} else {
/* If SGEHRD was not timed, generate a matrix and factor
it using SGEHRD anyway so that the factored form of
the matrix can be used in timing the other routines. */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
sgehrd_(&m, &ilo, &ihi, &a[1], &lda, &tau[1], &work[1], &
lw, &info);
}
if (timsub[2]) {
/* SORGHR: Generate the orthogonal matrix Q from the
reduction to Hessenberg form A = Q*H*Q' */
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = second_();
L50:
sorghr_(&m, &ilo, &ihi, &b[1], &lda, &tau[1], &work[1], &
lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L50;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L60:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L60;
}
time = (time - untime) / (real) ic;
/* Op count for SORGHR: same as
SORGQR( IHI-ILO, IHI-ILO, IHI-ILO, ... ) */
i__4 = ihi - ilo;
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORGQR", &i__4, &i__5, &i__6, &c__0, &nb);
reslts_ref(inb, im, ilda, 3) = smflop_(&ops, &time, &info)
;
}
if (timsub[3]) {
/* SORMHR: Multiply by Q stored as a product of
elementary transformations */
i4 = 3;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[
iside - 1];
i__4 = *nn;
for (in = 1; in <= i__4; ++in) {
n = nval[in];
/* Computing MAX */
i__5 = 1, i__6 = max(1,nb) * n;
lw = max(i__5,i__6);
if (iside == 1) {
m1 = m;
n1 = n;
} else {
m1 = n;
n1 = m;
}
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = second_();
L70:
sormhr_(side, trans, &m1, &n1, &ilo, &ihi, &a[
1], &lda, &tau[1], &b[1], &lda, &work[
1], &lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L70;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L80:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L80;
}
time = (time - untime) / (real) ic;
/* Op count for SORMHR, SIDE='L': same as
SORMQR( 'L', TRANS, IHI-ILO, N, IHI-ILO, ...)
Op count for SORMHR, SIDE='R': same as
SORMQR( 'R', TRANS, M, IHI-ILO, IHI-ILO, ...) */
if (iside == 1) {
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORMQR", &i__5, &n1, &i__6,
&c_n1, &nb);
} else {
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORMQR", &m1, &i__5, &i__6,
&c__1, &nb);
}
reslts_ref(inb, im, ilda, i4 + itoff + in) =
smflop_(&ops, &time, &info);
itoff = *nn;
/* L90: */
}
/* L100: */
}
i4 += *nn << 1;
/* L110: */
}
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* Print tables of results for SGEHRD, ORTHES, and SORGHR */
for (isub = 1; isub <= 3; ++isub) {
if (! timsub[isub - 1]) {
goto L160;
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
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___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L150: */
}
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
e_wsfe();
if (isub == 2) {
sprtb3_(" ", "N", &c__1, &nbval[1], &nxval[1], nm, &mval[1], nlda,
&reslts_ref(1, 1, 1, isub), ldr1, ldr2, nout, (ftnlen)1,
(ftnlen)1);
} else {
sprtb3_("( NB, NX)", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], nlda, &reslts_ref(1, 1, 1, isub), ldr1, ldr2, nout, (
ftnlen)11, (ftnlen)1);
}
L160:
;
}
/* Print tables of results for SORMHR */
isub = 4;
if (timsub[isub - 1]) {
i4 = 3;
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)lab1 = 'M';
*(unsigned char *)lab2 = 'N';
if (*nlda > 1) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(
integer));
e_wsfe();
/* L170: */
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
e_wsfe();
}
} else {
*(unsigned char *)lab1 = 'N';
*(unsigned char *)lab2 = 'M';
}
for (itran = 1; itran <= 2; ++itran) {
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, sides + (iside - 1), (ftnlen)1);
do_fio(&c__1, transs + (itran - 1), (ftnlen)1);
do_fio(&c__1, lab2, (ftnlen)1);
do_fio(&c__1, (char *)&nval[in], (ftnlen)sizeof(integer));
e_wsfe();
sprtbl_("NB", lab1, nnb, &nbval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, i4 + in), ldr1, ldr2, nout, (
ftnlen)2, (ftnlen)1);
/* L180: */
}
i4 += *nn;
/* L190: */
}
/* L200: */
}
}
L210:
/* Print a table of results for each timed routine. */
return 0;
/* End of STIMHR */
} /* stimhr_ */
/* Subroutine */ int ztimql_(char *line, integer *nm, integer *mval, integer *
nval, integer *nk, integer *kval, integer *nnb, integer *nbval,
integer *nxval, integer *nlda, integer *ldaval, doublereal *timmin,
doublecomplex *a, doublecomplex *tau, doublecomplex *b, doublecomplex
*work, doublereal *rwork, doublereal *reslts, integer *ldr1, integer *
ldr2, integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*3] = "ZGEQLF" "ZUNGQL" "ZUNMQL";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "C";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9996[] = "(5x,\002K = min(M,N)\002,/)";
static char fmt_9995[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', TRANS"
" = '\002,a1,\002', \002,a1,\002 =\002,i6,/)";
static char fmt_9994[] = "(\002 *** No pairs (M,N) found with M >= N: "
" \002,a6,\002 not timed\002)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda;
static char labm[1], side[1];
static integer info;
static char path[3];
static doublereal time;
static integer isub, muse[12], nuse[12], i__, k, m, n;
static char cname[6];
static integer iside;
extern doublereal dopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer itoff, itran, minmn;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer k1, i4, m1, n1;
static doublereal s1, s2;
extern /* Subroutine */ int dprtb4_(char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, ftnlen, ftnlen,
ftnlen), dprtb5_(char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *, ftnlen, ftnlen, ftnlen);
static integer ic, nb, ik, im;
extern doublereal dsecnd_(void);
static integer lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), zgeqlf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), xlaenv_(integer *,
integer *);
static doublereal untime;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical timsub[3];
extern /* Subroutine */ int ztimmg_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zunmql_(char *, char *, integer *, integer
*, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lda, icl, inb, imx;
static doublereal ops;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTIMQL times the LAPACK routines to perform the QL factorization of
a COMPLEX*16 general matrix.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M and N contained in the vectors
MVAL and NVAL. The matrix sizes are used in pairs (M,N).
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NVAL (input) INTEGER array, dimension (NM)
The values of the matrix column dimension N.
NK (input) INTEGER
The number of values of K in the vector KVAL.
KVAL (input) INTEGER array, dimension (NK)
The values of the matrix dimension K, used in ZUNMQL.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) DOUBLE PRECISION
The minimum time a subroutine will be timed.
A (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) COMPLEX*16 array, dimension (min(M,N))
B (workspace) COMPLEX*16 array, dimension (LDAMAX*NMAX)
WORK (workspace) COMPLEX*16 array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
RWORK (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
RESLTS (workspace) DOUBLE PRECISION array, dimension
(LDR1,LDR2,LDR3,2*NK)
The timing results for each subroutine over the relevant
values of (M,N), (NB,NX), and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See ZLATMS for further details.
COND DOUBLE PRECISION
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX DOUBLE PRECISION
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kval;
--nbval;
--nxval;
--ldaval;
--a;
--tau;
--b;
--work;
--rwork;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__3, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L230;
}
/* Check that M <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__1, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L230;
}
/* Do for each pair of values (M,N): */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
n = nval[im];
minmn = min(m,n);
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = n * max(1,nb);
lw = max(i__4,i__5);
/* Generate a test matrix of size M by N. */
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[0]) {
/* ZGEQLF: QL factorization */
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = dsecnd_();
L10:
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L20:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_("Full", &m, &n, &a[1], &lda, &b[1], &lda);
goto L20;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("ZGEQLF", &m, &n, &c__0, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = dmflop_(&ops, &time, &info)
;
} else {
/* If ZGEQLF was not timed, generate a matrix and factor
it using ZGEQLF anyway so that the factored form of
the matrix can be used in timing the other routines. */
zlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
}
if (timsub[1]) {
/* ZUNGQL: Generate orthogonal matrix Q from the QL
factorization */
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = dsecnd_();
L30:
zungql_(&m, &minmn, &minmn, &b[1], &lda, &tau[1], &work[1]
, &lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L30;
}
/* Subtract the time used in ZLACPY. */
icl = 1;
s1 = dsecnd_();
L40:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
zlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("ZUNGQL", &m, &minmn, &minmn, &c__0, &nb);
reslts_ref(inb, im, ilda, 2) = dmflop_(&ops, &time, &info)
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* Print tables of results */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L90;
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L80: */
}
}
io___32.ciunit = *nout;
s_wsle(&io___32);
e_wsle();
if (isub == 2) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
}
dprtb4_("( NB, NX)", "M", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], &nval[1], nlda, &reslts_ref(1, 1, 1, isub), ldr1, ldr2,
nout, (ftnlen)11, (ftnlen)1, (ftnlen)1);
L90:
;
}
/* Time ZUNMQL separately. Here the starting matrix is M by N, and
K is the free dimension of the matrix multiplied by Q. */
if (timsub[2]) {
/* Check that K <= LDA for the input values. */
atimck_(&c__3, cname, nk, &kval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, subnam_ref(0, 3), (ftnlen)6);
e_wsfe();
goto L230;
}
/* Use only the pairs (M,N) where M >= N. */
imx = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
if (mval[im] >= nval[im]) {
++imx;
muse[imx - 1] = mval[im];
nuse[imx - 1] = nval[im];
}
/* L100: */
}
/* ZUNMQL: Multiply by Q stored as a product of elementary
transformations
Do for each pair of values (M,N): */
i__1 = imx;
for (im = 1; im <= i__1; ++im) {
m = muse[im - 1];
n = nuse[im - 1];
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Generate an M by N matrix and form its QL decomposition. */
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &a[1], &lda, &
work[1], &info);
/* Computing MAX */
i__3 = 1, i__4 = n * max(1,nb);
lw = max(i__3,i__4);
zgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &info);
/* Do first for SIDE = 'L', then for SIDE = 'R' */
i4 = 0;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside -
1];
/* Do for each pair of values (NB, NX) in NBVAL and
NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Do for each value of K in KVAL */
i__4 = *nk;
for (ik = 1; ik <= i__4; ++ik) {
k = kval[ik];
/* Sort out which variable is which */
if (iside == 1) {
m1 = m;
k1 = n;
n1 = k;
/* Computing MAX */
i__5 = 1, i__6 = n1 * max(1,nb);
lw = max(i__5,i__6);
} else {
n1 = m;
k1 = n;
m1 = k;
/* Computing MAX */
i__5 = 1, i__6 = m1 * max(1,nb);
lw = max(i__5,i__6);
}
/* Do first for TRANS = 'N', then for TRANS = 'T' */
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L110:
zunmql_(side, trans, &m1, &n1, &k1, &a[1], &
lda, &tau[1], &b[1], &lda, &work[1], &
lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L110;
}
/* Subtract the time used in ZTIMMG. */
icl = 1;
s1 = dsecnd_();
L120:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ztimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L120;
}
time = (time - untime) / (doublereal) ic;
i__5 = iside - 1;
ops = dopla_("ZUNMQL", &m1, &n1, &k1, &i__5, &
nb);
reslts_ref(inb, im, ilda, i4 + itoff + ik) =
dmflop_(&ops, &time, &info);
itoff = *nk;
/* L130: */
}
/* L140: */
}
/* L150: */
}
i4 = *nk << 1;
/* L160: */
}
/* L170: */
}
/* L180: */
}
/* Print tables of results */
isub = 3;
i4 = 1;
if (imx >= 1) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
if (iside == 1) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)
sizeof(integer));
e_wsfe();
/* L190: */
}
}
}
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
i__1 = *nk;
for (ik = 1; ik <= i__1; ++ik) {
if (iside == 1) {
n = kval[ik];
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'M';
} else {
m = kval[ik];
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'N';
}
dprtb5_("NB", labm, "K", nnb, &nbval[1], &imx, muse,
nuse, nlda, &reslts_ref(1, 1, 1, i4), ldr1,
ldr2, nout, (ftnlen)2, (ftnlen)1, (ftnlen)1);
++i4;
/* L200: */
}
/* L210: */
}
/* L220: */
}
} else {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
}
}
L230:
return 0;
/* End of ZTIMQL */
} /* ztimql_ */
/* Subroutine */ int cdrvpb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
" \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
",i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
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;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
integer nfail, iseed[4], nfact;
extern /* Subroutine */ int cpbt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *),
cpbt02_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *), cpbt05_(char *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *, real *);
integer kdval[4];
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
extern doublereal sget06_(real *, real *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cpbsv_(char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, integer *);
logical equil;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *), clange_(char *, integer *,
integer *, complex *, integer *, real *);
extern /* Subroutine */ int claqhb_(char *, integer *, integer *, complex
*, integer *, real *, real *, real *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *), claipd_(integer *,
complex *, integer *, integer *);
logical prefac;
real rcondc;
logical nofact;
char packit[1];
integer iequed;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), clarhs_(char *, char
*, char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), cpbequ_(char *, integer *, integer
*, complex *, integer *, real *, real *, real *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
*);
real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *), cpbtrf_(char *, integer *, integer *, complex *,
integer *, integer *);
real ainvnm;
extern /* Subroutine */ int cpbtrs_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, integer *),
xlaenv_(integer *, integer *), cpbsvx_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
char *, real *, complex *, integer *, complex *, integer *, real
*, real *, real *, complex *, real *, integer *), cerrvx_(char *, integer *);
real result[6];
/* 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 */
/* ======= */
/* CDRVPB tests the driver routines CPBSV 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) COMPLEX array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--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, "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) {
cerrvx_(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 CLATB4 and generate a test */
/* matrix with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)
6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &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;
ccopy_(&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);
ccopy_(&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);
ccopy_(&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;
ccopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix */
/* to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = iw + i__;
work[i__5].r = 0.f, work[i__5].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;
cswap_(&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);
cswap_(&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);
cswap_(&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;
cswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[kd + 1], &ldab, &c__0);
} else {
claipd_(&n, &a[1], &ldab, &c__0);
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
clacpy_("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 CPBSVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__5 = kd + 1;
clacpy_("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. */
cpbequ_(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. */
claqhb_(uplo, &n, &kd, &afac[1], &
ldab, &s[1], &scond, &amax,
equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in CGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = clanhb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
cpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
claset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)6, (
ftnlen)6);
cpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clange_("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;
clacpy_("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, "CLARHS", (ftnlen)6, (
ftnlen)6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
&lda, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
lda);
if (nofact) {
/* --- Test CPBSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
i__5 = kd + 1;
clacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "CPBSV ", (ftnlen)6, (
ftnlen)6);
cpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from CPBSV . */
if (info != izero) {
alaerh_(path, "CPBSV ", &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. */
cpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
cpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&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, "CPBSV ", (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 CPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
claset_("Full", &i__5, &n, &c_b47, &c_b47, &
afac[1], &ldab);
}
claset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y' */
claqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using CPBSVX. */
s_copy(srnamc_1.srnamt, "CPBSVX", (ftnlen)6, (
ftnlen)6);
cpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
afac[1], &ldab, equed, &s[1], &b[1], &lda,
&x[1], &lda, &rcond, &rwork[1], &rwork[*
nrhs + 1], &work[1], &rwork[(*nrhs << 1)
+ 1], &info);
/* Check the error code from CPBSVX. */
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, "CPBSVX", &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. */
cpbt01_(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. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
cpbt02_(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")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
cpbt05_(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 CPBSVX 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, "CPBSVX", (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, "CPBSVX", (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 CDRVPB */
} /* cdrvpb_ */
/* Subroutine */ int ddrvge_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test(\002,i2,\002) =\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
doublereal d__1;
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 */
extern /* Subroutine */ int debchvxx_(doublereal *, char *);
integer i__, k, n;
doublereal *errbnds_c__, *errbnds_n__;
integer k1, nb, in, kl, ku, nt, n_err_bnds__;
extern doublereal dla_rpvgrw__(integer *, integer *, doublereal *,
integer *, doublereal *, integer *);
integer lda;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
doublereal *berr;
char dist[1];
doublereal rpvgrw_svxx__;
char type__[1];
integer nrun;
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 *);
integer ifact;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, logical *,
doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
doublereal rcond, roldc;
integer nimat;
doublereal roldi;
extern /* Subroutine */ int dgesv_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *);
doublereal anorm;
integer itran;
logical equil;
doublereal roldo;
char trans[1];
integer izero, nerrs, lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *);
extern doublereal dlamch_(char *), 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 *), dlaqge_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, char *);
logical prefac;
doublereal colcnd, rcondc;
logical nofact;
integer iequed;
extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
doublereal rcondi;
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dgetri_(integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), alasvm_(char *, integer *,
integer *, integer *, integer *);
doublereal cndnum, anormi, rcondo, ainvnm;
extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *);
logical trfcon;
doublereal anormo, rowcnd;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dgesvx_(char *, char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, char *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
, integer *), dlatms_(integer *, integer *
, char *, integer *, char *, doublereal *, integer *, doublereal *
, doublereal *, integer *, integer *, char *, doublereal *,
integer *, doublereal *, integer *),
xlaenv_(integer *, integer *), derrvx_(char *, integer *);
doublereal result[7], rpvgrw;
extern /* Subroutine */ int dgesvxx_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
char *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___74 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___75 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___76 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___78 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___80 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___81 = { 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 */
/* ======= */
/* DDRVGE tests the driver routines DGESV, -SVX, and -SVXX. */
/* Note that this file is used only when the XBLAS are available, */
/* otherwise ddrvge.f defines this subroutine. */
/* 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 column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "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) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L80;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cndnum, dist);
rcondc = 1. / cndnum;
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &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, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L80;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__3 = n - izero + 1;
dlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
lda);
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondo = 0.;
rcondi = 0.;
} else if (! nofact) {
/* Compute the condition number for comparison with */
/* the value returned by DGESVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
&rowcnd, &colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R"))
{
rowcnd = 0.;
colcnd = 1.;
} else if (lsame_(equed, "C")) {
rowcnd = 1.;
colcnd = 0.;
} else if (lsame_(equed, "B")) {
rowcnd = 0.;
colcnd = 0.;
}
/* Equilibrate the matrix. */
dlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
1], &rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the non-equilibrated */
/* system for use in DGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = dlange_("1", &n, &n, &afac[1], &lda, &rwork[
1]);
anormi = dlange_("I", &n, &n, &afac[1], &lda, &rwork[
1]);
/* Factor the matrix A. */
dgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
/* Form the inverse of A. */
dlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
lwork = *nmax * max(3,*nrhs);
dgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
&info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
if (anormo <= 0. || ainvnm <= 0.) {
rcondo = 1.;
} else {
rcondo = 1. / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of A. */
ainvnm = dlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
for (i__ = 1; i__ <= 7; ++i__) {
result[i__ - 1] = 0.;
}
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, "Full", 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, &bsav[1], &lda);
if (nofact && itran == 1) {
/* --- Test DGESV --- */
/* Compute the LU factorization of the matrix and */
/* solve the system. */
dlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
lda);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (
ftnlen)6);
dgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
&lda, &info);
/* Check error code from DGESV . */
if (info != izero) {
alaerh_(path, "DGESV ", &info, &izero, " ", &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L50;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
dget02_("No transpose", &n, &n, nrhs, &a[1], &
lda, &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, "DGESV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
}
/* --- Test DGESVX --- */
if (! prefac) {
dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DGESVX. */
s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)
6);
dgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check the error code from DGESVX. */
if (info == n + 1) {
goto L50;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DGESVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L50;
}
/* Compare WORK(1) from DGESVX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info != 0) {
rpvgrw = dlantr_("M", "U", "N", &info, &info, &
afac[1], &lda, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", &n, &info, &a[1], &lda,
&work[1]) / rpvgrw;
}
} else {
rpvgrw = dlantr_("M", "U", "N", &n, &n, &afac[1],
&lda, &work[1]);
if (rpvgrw == 0.) {
rpvgrw = 1.;
} else {
rpvgrw = dlange_("M", &n, &n, &a[1], &lda, &
work[1]) / rpvgrw;
}
}
result[6] = (d__1 = rpvgrw - work[1], abs(d__1)) /
max(work[1],rpvgrw) / dlamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &c_true, &rwork[*nrhs + 1], &result[3]
);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from DGESVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___62.ciunit = *nout;
s_wsfe(&io___62);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L40: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___63.ciunit = *nout;
s_wsfe(&io___63);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___64.ciunit = *nout;
s_wsfe(&io___64);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___66.ciunit = *nout;
s_wsfe(&io___66);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___67.ciunit = *nout;
s_wsfe(&io___67);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___68.ciunit = *nout;
s_wsfe(&io___68);
do_fio(&c__1, "DGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* --- Test DGESVXX --- */
/* Restore the matrices A and B. */
dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
if (! prefac) {
dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DGESVXX. */
s_copy(srnamc_1.srnamt, "DGESVXX", (ftnlen)32, (
ftnlen)7);
n_err_bnds__ = 3;
dalloc3();
dgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
berr, &n_err_bnds__, errbnds_n__,
errbnds_c__, &c__0, &c_b20, &work[1], &iwork[
n + 1], &info);
free3();
/* Check the error code from DGESVXX. */
if (info == n + 1) {
goto L50;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DGESVXX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L50;
}
/* Compare rpvgrw_svxx from DGESVXX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info > 0 && info < n + 1) {
rpvgrw = dla_rpvgrw__(&n, &info, &a[1], &lda, &
afac[1], &lda);
} else {
rpvgrw = dla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
1], &lda);
}
result[6] = (d__1 = rpvgrw - rpvgrw_svxx__, abs(d__1))
/ max(rpvgrw_svxx__,rpvgrw) / dlamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
} else {
trfcon = TRUE_;
}
/* Compare RCOND from DGESVXX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___74.ciunit = *nout;
s_wsfe(&io___74);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___75.ciunit = *nout;
s_wsfe(&io___75);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L45: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___76.ciunit = *nout;
s_wsfe(&io___76);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___77.ciunit = *nout;
s_wsfe(&io___77);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___78.ciunit = *nout;
s_wsfe(&io___78);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___79.ciunit = *nout;
s_wsfe(&io___79);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___80.ciunit = *nout;
s_wsfe(&io___80);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___81.ciunit = *nout;
s_wsfe(&io___81);
do_fio(&c__1, "DGESVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
++nfail;
++nrun;
}
}
L50:
;
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
/* Test Error Bounds from DGESVXX */
debchvxx_(thresh, path);
return 0;
/* End of DDRVGE */
} /* ddrvge_ */
integer i1mach_(integer *i__)
{
/* Initialized data */
static integer sanity = 987;
static struct {
integer e_1[16];
} equiv_0 = {{ 5, 6, 7, 6, 32, 4, 2, 31, 2147483647, 2, 24, -125, 128, 53, -1021, 1024 }};
/* Format strings */
static char fmt_1999[] = "(\002 I1MACH - I OUT OF BOUNDS\002,i10)";
/* System generated locals */
integer ret_val=0;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
#define imach ((integer *)&equiv_0)
#define output ((integer *)&equiv_0 + 3)
/* Fortran I/O blocks */
static cilist io___14 = { 0, 0, 0, fmt_1999, 0 };
/* I/O UNIT NUMBERS. */
/* I1MACH( 1) = THE STANDARD INPUT UNIT. */
/* I1MACH( 2) = THE STANDARD OUTPUT UNIT. */
/* I1MACH( 3) = THE STANDARD PUNCH UNIT. */
/* I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. */
/* WORDS. */
/* I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. */
/* I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. */
/* FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN 66, */
/* CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT. */
/* INTEGERS. */
/* ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM */
/* SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) */
/* WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. */
/* I1MACH( 7) = A, THE BASE. */
/* I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. */
/* I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. */
/* FLOATING-POINT NUMBERS. */
/* ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, */
/* BASE-B FORM */
/* SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) */
/* WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, */
/* 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. */
/* I1MACH(10) = B, THE BASE. */
/* SINGLE-PRECISION */
/* I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. */
/* I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. */
/* I1MACH(13) = EMAX, THE LARGEST EXPONENT E. */
/* DOUBLE-PRECISION */
/* I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. */
/* I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. */
/* I1MACH(16) = EMAX, THE LARGEST EXPONENT E. */
/* TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, */
/* THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY */
/* REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF */
/* I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY */
/* WITH THE LOCAL OPERATING SYSTEM. FOR FORTRAN 77, YOU MAY WISH */
/* TO ADJUST THE DATA STATEMENT SO IMACH(6) IS SET TO 1, AND */
/* THEN TO COMMENT OUT THE EXECUTABLE TEST ON I .EQ. 6 BELOW. */
/* ON RARE MACHINES A STATIC STATEMENT MAY NEED TO BE ADDED. */
/* (BUT PROBABLY MORE SYSTEMS PROHIBIT IT THAN REQUIRE IT.) */
/* FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST */
/* SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE, EXCEPT PERHAPS */
/* FOR IMACH(1) - IMACH(4). */
/* MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T */
/* 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T */
/* PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). */
/* MACHINE CONSTANTS FOR AMDAHL MACHINES. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / 2147483647 / */
/* DATA IMACH(10) / 16 / */
/* DATA IMACH(11) / 6 / */
/* DATA IMACH(12) / -64 / */
/* DATA IMACH(13) / 63 / */
/* DATA IMACH(14) / 14 / */
/* DATA IMACH(15) / -64 / */
/* DATA IMACH(16) / 63 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. */
/* DATA IMACH( 1) / 7 / */
/* DATA IMACH( 2) / 2 / */
/* DATA IMACH( 3) / 2 / */
/* DATA IMACH( 4) / 2 / */
/* DATA IMACH( 5) / 36 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 33 / */
/* DATA IMACH( 9) / Z1FFFFFFFF / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -256 / */
/* DATA IMACH(13) / 255 / */
/* DATA IMACH(14) / 60 / */
/* DATA IMACH(15) / -256 / */
/* DATA IMACH(16) / 255 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 48 / */
/* DATA IMACH( 6) / 6 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 39 / */
/* DATA IMACH( 9) / O0007777777777777 / */
/* DATA IMACH(10) / 8 / */
/* DATA IMACH(11) / 13 / */
/* DATA IMACH(12) / -50 / */
/* DATA IMACH(13) / 76 / */
/* DATA IMACH(14) / 26 / */
/* DATA IMACH(15) / -50 / */
/* DATA IMACH(16) / 76 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 48 / */
/* DATA IMACH( 6) / 6 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 39 / */
/* DATA IMACH( 9) / O0007777777777777 / */
/* DATA IMACH(10) / 8 / */
/* DATA IMACH(11) / 13 / */
/* DATA IMACH(12) / -50 / */
/* DATA IMACH(13) / 76 / */
/* DATA IMACH(14) / 26 / */
/* DATA IMACH(15) / -32754 / */
/* DATA IMACH(16) / 32780 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 60 / */
/* DATA IMACH( 6) / 10 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 48 / */
/* DATA IMACH( 9) / 00007777777777777777B / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 47 / */
/* DATA IMACH(12) / -929 / */
/* DATA IMACH(13) / 1070 / */
/* DATA IMACH(14) / 94 / */
/* DATA IMACH(15) / -929 / */
/* DATA IMACH(16) / 1069 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 60 / */
/* DATA IMACH( 6) / 10 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 48 / */
/* DATA IMACH( 9) / O"00007777777777777777" / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 47 / */
/* DATA IMACH(12) / -929 / */
/* DATA IMACH(13) / 1070 / */
/* DATA IMACH(14) / 94 / */
/* DATA IMACH(15) / -929 / */
/* DATA IMACH(16) / 1069 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR CONVEX C-1. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / 2147483647 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -128 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 53 / */
/* DATA IMACH(15) /-1024 / */
/* DATA IMACH(16) / 1023 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 102 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 64 / */
/* DATA IMACH( 6) / 8 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 63 / */
/* DATA IMACH( 9) / 777777777777777777777B / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 47 / */
/* DATA IMACH(12) / -8189 / */
/* DATA IMACH(13) / 8190 / */
/* DATA IMACH(14) / 94 / */
/* DATA IMACH(15) / -8099 / */
/* DATA IMACH(16) / 8190 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. */
/* DATA IMACH( 1) / 11 / */
/* DATA IMACH( 2) / 12 / */
/* DATA IMACH( 3) / 8 / */
/* DATA IMACH( 4) / 10 / */
/* DATA IMACH( 5) / 16 / */
/* DATA IMACH( 6) / 2 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 15 / */
/* DATA IMACH( 9) /32767 / */
/* DATA IMACH(10) / 16 / */
/* DATA IMACH(11) / 6 / */
/* DATA IMACH(12) / -64 / */
/* DATA IMACH(13) / 63 / */
/* DATA IMACH(14) / 14 / */
/* DATA IMACH(15) / -64 / */
/* DATA IMACH(16) / 63 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 0 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 24 / */
/* DATA IMACH( 6) / 3 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 23 / */
/* DATA IMACH( 9) / 8388607 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 23 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 38 / */
/* DATA IMACH(15) / -127 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 43 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 36 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 35 / */
/* DATA IMACH( 9) / O377777777777 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 27 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 63 / */
/* DATA IMACH(15) / -127 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, */
/* THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / Z7FFFFFFF / */
/* DATA IMACH(10) / 16 / */
/* DATA IMACH(11) / 6 / */
/* DATA IMACH(12) / -64 / */
/* DATA IMACH(13) / 63 / */
/* DATA IMACH(14) / 14 / */
/* DATA IMACH(15) / -64 / */
/* DATA IMACH(16) / 63 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE INTERDATA 8/32 */
/* WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. */
/* FOR THE INTERDATA FORTRAN VII COMPILER REPLACE */
/* THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 6 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / Z'7FFFFFFF' / */
/* DATA IMACH(10) / 16 / */
/* DATA IMACH(11) / 6 / */
/* DATA IMACH(12) / -64 / */
/* DATA IMACH(13) / 62 / */
/* DATA IMACH(14) / 14 / */
/* DATA IMACH(15) / -64 / */
/* DATA IMACH(16) / 62 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 36 / */
/* DATA IMACH( 6) / 5 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 35 / */
/* DATA IMACH( 9) / "377777777777 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 27 / */
/* DATA IMACH(12) / -128 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 54 / */
/* DATA IMACH(15) / -101 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 36 / */
/* DATA IMACH( 6) / 5 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 35 / */
/* DATA IMACH( 9) / "377777777777 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 27 / */
/* DATA IMACH(12) / -128 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 62 / */
/* DATA IMACH(15) / -128 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING */
/* 32-BIT INTEGER ARITHMETIC. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / 2147483647 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 56 / */
/* DATA IMACH(15) / -127 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING */
/* 16-BIT INTEGER ARITHMETIC. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 16 / */
/* DATA IMACH( 6) / 2 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 15 / */
/* DATA IMACH( 9) / 32767 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 56 / */
/* DATA IMACH(15) / -127 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS */
/* WTIH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, */
/* SUPPLIED BY IGOR BRAY. */
/* DATA IMACH( 1) / 1 / */
/* DATA IMACH( 2) / 1 / */
/* DATA IMACH( 3) / 2 / */
/* DATA IMACH( 4) / 1 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / :17777777777 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 23 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / +127 / */
/* DATA IMACH(14) / 47 / */
/* DATA IMACH(15) / -32895 / */
/* DATA IMACH(16) / +32637 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. */
/* DATA IMACH( 1) / 0 / */
/* DATA IMACH( 2) / 0 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 0 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 1 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / 2147483647 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -125 / */
/* DATA IMACH(13) / 128 / */
/* DATA IMACH(14) / 53 / */
/* DATA IMACH(15) / -1021 / */
/* DATA IMACH(16) / 1024 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. */
/* NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 */
/* WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. */
/* IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 36 / */
/* DATA IMACH( 6) / 6 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 35 / */
/* DATA IMACH( 9) / O377777777777 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 27 / */
/* DATA IMACH(12) / -128 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 60 / */
/* DATA IMACH(15) /-1024 / */
/* DATA IMACH(16) / 1023 /, SANITY/987/ */
/* MACHINE CONSTANTS FOR VAX. */
/* DATA IMACH( 1) / 5 / */
/* DATA IMACH( 2) / 6 / */
/* DATA IMACH( 3) / 7 / */
/* DATA IMACH( 4) / 6 / */
/* DATA IMACH( 5) / 32 / */
/* DATA IMACH( 6) / 4 / */
/* DATA IMACH( 7) / 2 / */
/* DATA IMACH( 8) / 31 / */
/* DATA IMACH( 9) / 2147483647 / */
/* DATA IMACH(10) / 2 / */
/* DATA IMACH(11) / 24 / */
/* DATA IMACH(12) / -127 / */
/* DATA IMACH(13) / 127 / */
/* DATA IMACH(14) / 56 / */
/* DATA IMACH(15) / -127 / */
/* DATA IMACH(16) / 127 /, SANITY/987/ */
/* *** ISSUE STOP 777 IF ALL DATA STATEMENTS ARE COMMENTED... */
if(sanity != 987) {
s_stop("777", (ftnlen)3);
}
if(*i__ < 1 || *i__ > 16) {
goto L10;
}
ret_val = imach[*i__ - 1];
/* /6S */
/* /7S */
if(*i__ == 6) {
ret_val = 1;
}
/* / */
return ret_val;
L10:
io___14.ciunit = *output;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&(*i__), (ftnlen)sizeof(integer));
e_wsfe();
s_stop("", (ftnlen)0);
return ret_val;
} /* i1mach_ */
/* Subroutine */ int cdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, complex *a, integer *lda, complex *h__, complex *w,
complex *w1, complex *vl, integer *ldvl, complex *vr, integer *ldvr,
complex *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
scale1, real *result, complex *work, integer *nwork, real *rwork,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 CDRVVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
"see CDRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
complex q__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),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n;
real wi, wr;
integer iwk;
real ulp;
integer ibal;
real cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
integer isrt;
logical badnn;
extern /* Subroutine */ int cget23_(logical *, integer *, char *, integer
*, real *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, complex *, integer *,
real *, integer *);
integer nfail, imode, iinfo;
real conds, anorm;
integer jsize, nerrs, itype, jtype, ntest;
real rtulp;
char balanc[1];
extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
char *, integer *, complex *, integer *, real *, complex *, char *
, char *, char *, char *, real *, integer *, real *, integer *,
integer *, real *, complex *, integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
integer ioldsd[4];
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 *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*);
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
real ulpinv;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___45 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVVX checks the nonsymmetric eigenvalue problem expert driver */
/* CGEEVX. */
/* CDRVVX 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 CDRVVX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified in the calling sequence. */
/* For each size ("n") and each type of matrix, one matrix will be */
/* generated and used to test the nonsymmetric eigenroutines. For */
/* each matrix, 9 tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
/* and RCONDE are also computed, and W(partial) denotes the */
/* eigenvalues computed when only some of VR, VL, RCONDV, and */
/* RCONDE are computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
/* and RCONDE are computed, and VR(partial) denotes the result */
/* when only some of VL and RCONDV are computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
/* and RCONDE are computed, and VL(partial) denotes the result */
/* when only some of VR and RCONDV are computed. */
/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
/* SCALE, ILO, IHI, ABNRM (partial) */
/* 1/ulp otherwise */
/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
/* (partial) is when some are not computed. */
/* (9) RCONDV(full) = RCONDV(partial) */
/* RCONDV(full) denotes the reciprocal condition numbers of the */
/* right eigenvectors computed when VR, VL and RCONDE are also */
/* computed. RCONDV(partial) denotes the reciprocal condition */
/* numbers when only some of VR, VL and RCONDE are computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalues */
/* and right eigenvectors. For these matrices, in addition to tests */
/* (1) to (9) we will compute the following two tests: */
/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right eigenvector condition number */
/* computed by CGEEVX and RCDVIN (the precomputed true value) */
/* is supplied as input. cond(RCONDV) is the condition number of */
/* RCONDV, and takes errors in computing RCONDV into account, so */
/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
/* essentially given by norm(A)/RCONDE. */
/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal eigenvalue condition number */
/* computed by CGEEVX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CDRVVX 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) COMPLEX array, dimension (LDA, max(NN,12)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN, 12 ). (12 is the */
/* dimension of the largest matrix on the precomputed */
/* input file.) */
/* H (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
/* Another copy of the test matrix A, modified by CGEEVX. */
/* W (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Contains the eigenvalues of A. */
/* W1 (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when CGEEVX only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX array, dimension (LDVL, max(NN,12)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
/* VR (workspace) COMPLEX array, dimension (LDVR, max(NN,12)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
/* LRE (workspace) COMPLEX array, dimension (LDLRE, max(NN,12)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
/* RESULT (output) REAL array, dimension (11) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
/* RWORK (workspace) REAL array, dimension (2*max(NN,12)) */
/* INFO (output) INTEGER */
/* If 0, then successful exit. */
/* If <0, then input paramter -INFO is incorrect. */
/* If >0, CLATMR, CLATMS, CLATME or CGET23 returned an error */
/* code, and INFO is its absolute value. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN or 12. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--rwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 7 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 7;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -15;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -17;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -19;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -30;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* 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 L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&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.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&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 */
clatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
&iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
if (n >= 4) {
claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = (n << 1) + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
cget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &
work[1], &nnwork, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___40.ciunit = *nounit;
s_wsfe(&io___40);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation. */
/* Assume input eigenvalues are sorted lexicographically (increasing */
/* by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___45.ciunit = *niunit;
i__1 = s_rsle(&io___45);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__4, &c__1, (char *)&wr, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wi, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
e_rsle();
i__2 = i__;
q__1.r = wr, q__1.i = wi;
w1[i__2].r = q__1.r, w1[i__2].i = q__1.i;
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
cget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of CDRVVX */
} /* cdrvvx_ */
/* Subroutine */ int stest_(integer *len, real *scomp, real *strue, real *
ssize, real *sfac)
{
/* Format strings */
static char fmt_99999[] = "(\002 F"
"AIL\002)";
static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I "
" \002,\002 COMP(I) TRU"
"E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)";
static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2e36.8,2e12.4)";
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__;
real sd;
extern doublereal sdiff_(real *, real *);
/* Fortran I/O blocks */
static cilist io___105 = { 0, 6, 0, fmt_99999, 0 };
static cilist io___106 = { 0, 6, 0, fmt_99998, 0 };
static cilist io___107 = { 0, 6, 0, fmt_99997, 0 };
/* ********************************* STEST ************************** */
/* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */
/* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
/* NEGLIGIBLE. */
/* C. L. LAWSON, JPL, 1974 DEC 10 */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. Intrinsic Functions .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ssize;
--strue;
--scomp;
/* Function Body */
i__1 = *len;
for (i__ = 1; i__ <= i__1; ++i__) {
sd = scomp[i__] - strue[i__];
r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs(
r__2));
r__5 = (r__3 = ssize[i__], dabs(r__3));
if (sdiff_(&r__4, &r__5) == 0.f) {
goto L40;
}
/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */
if (! combla_1.pass) {
goto L20;
}
/* PRINT FAIL MESSAGE AND HEADER. */
combla_1.pass = FALSE_;
s_wsfe(&io___105);
e_wsfe();
s_wsfe(&io___106);
e_wsfe();
L20:
s_wsfe(&io___107);
do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(real));
e_wsfe();
L40:
;
}
return 0;
} /* stest_ */