/* Main program */ int MAIN__(void)
{
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
integer patch, major, minor;
extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___4 = { 0, 6, 0, 0, 0 };
ilaver_(&major, &minor, &patch);
s_wsle(&io___4);
do_lio(&c__9, &c__1, "LAPACK ", (ftnlen)7);
do_lio(&c__3, &c__1, (char *)&major, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ".", (ftnlen)1);
do_lio(&c__3, &c__1, (char *)&minor, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ".", (ftnlen)1);
do_lio(&c__3, &c__1, (char *)&patch, (ftnlen)sizeof(integer));
e_wsle();
return 0;
} /* MAIN__ */
/* Subroutine */ int check0_(doublereal *sfac)
{
/* Initialized data */
static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer k;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), stest1_(doublereal *, doublereal *, doublereal *
, doublereal *);
static doublereal sa, sb, sc, ss;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
/* Compute true values which cannot be prestored
in decimal notation */
dbtrue[0] = 1.6666666666666667;
dbtrue[2] = -1.6666666666666667;
dbtrue[4] = 1.6666666666666667;
for (k = 1; k <= 8; ++k) {
combla_1.n = k;
if (combla_1.icase == 3) {
if (k > 8) {
goto L40;
}
sa = da1[k - 1];
sb = db1[k - 1];
drotg_(&sa, &sb, &sc, &ss);
stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
} else {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L20: */
}
L40:
return 0;
} /* check0_
/* whatsoever. */
/* Subroutine */ int wavelet_(integer *n, doublereal *y, doublereal *dt,
integer *mother, doublereal *param, doublereal *s0, doublereal *dj,
integer *jtot, integer *npad, doublecomplex *wave, doublereal *scale,
doublereal *period, doublereal *coi)
{
/* System generated locals */
integer wave_dim1, wave_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double atan(doublereal);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double pow_dd(doublereal *, doublereal *);
/* Local variables */
doublecomplex daughter[65535];
integer i__, j, k;
doublereal pi, coi1;
doublecomplex yfft[65535];
doublereal freq1;
extern /* Subroutine */ int cfftb_(integer *, doublecomplex *, doublereal
*), cfftf_(integer *, doublecomplex *, doublereal *), cffti_(
integer *, doublereal *);
doublereal ymean, kwave[65535], wsave[262155];
extern /* Subroutine */ int wave_function__(integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublecomplex *);
doublereal period1;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 6, 0, 0, 0 };
/* ** initialize work arrays */
/* Parameter adjustments */
--coi;
--y;
--period;
--scale;
wave_dim1 = *n;
wave_offset = 1 + wave_dim1;
wave -= wave_offset;
/* Function Body */
pi = atan(1.) * 4.;
if (*npad < *n) {
s_wsle(&io___2);
do_lio(&c__9, &c__1, "**WAVELET: \"npad\" must be greater than or eq\
ual to \"n\"", (ftnlen)54);
e_wsle();
return 0;
}
/* PURE fio_swsle PUREGVA */
int fio_swsle( int cierr, int ciunit, int ciend, const char* cifmt, int cirec )
{
cilist params;
params.cierr = cierr;
params.ciunit = ciunit;
params.ciend = ciend;
params.cifmt = cifmt;
params.cirec = cirec;
return s_wsle( ¶ms );
}
// address: 80486cc
void MAIN__(__size32 param1) {
int local0; // m[esp - 16]
s_wsle();
do_lio();
e_wsle();
s_rsle();
do_lio();
e_rsle();
if (param1 == 2) {
}
if (param1 == 3) {
}
if (param1 == 4) {
}
switch(local0) {
case 0x8048760:
s_wsle();
do_lio();
e_wsle();
break;
case 0x8048793:
s_wsle();
do_lio();
e_wsle();
break;
case 0x80487c3:
s_wsle();
do_lio();
e_wsle();
break;
case 0x80487f3:
s_wsle();
do_lio();
e_wsle();
break;
}
return;
}
/* * *************************************************************************** */
/* Main program */ int MAIN__(void)
{
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 6, 0, 0, 0 };
s_wsle(&io___1);
do_lio(&c__9, &c__1, "Hello, Word!", (ftnlen)12);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int serrgt_(char *path, integer *nunit)
{
/* System generated locals */
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real b[2], c__[2], d__[2], e[2], f[2], w[2], x[2];
char c2[2];
real r1[2], r2[2], cf[2], df[2], ef[2];
integer ip[2], iw[2], info;
real rcond, anorm;
extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), sgtcon_(char *, integer *, real *, real *,
real *, real *, integer *, real *, real *, real *, integer *,
integer *), sptcon_(integer *, real *, real *, real *,
real *, real *, integer *), sgtrfs_(char *, integer *, integer *,
real *, real *, real *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, real *, real *, real *,
integer *, integer *), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *), sptrfs_(integer *, integer
*, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, real *, real *, integer *), spttrf_(integer *,
real *, real *, integer *), sgttrs_(char *, integer *, integer *,
real *, real *, real *, real *, integer *, real *, integer *,
integer *), spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRGT tests the error exits for the REAL tridiagonal */
/* routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
d__[0] = 1.f;
d__[1] = 2.f;
df[0] = 1.f;
df[1] = 2.f;
e[0] = 3.f;
e[1] = 4.f;
ef[0] = 3.f;
ef[1] = 4.f;
anorm = 1.f;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GT")) {
/* Test error exits for the general tridiagonal routines. */
/* SGTTRF */
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgttrf_(&c_n1, c__, d__, e, f, ip, &info);
chkxer_("SGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTTRS */
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgttrs_("/", &c__0, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgttrs_("N", &c_n1, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgttrs_("N", &c__0, &c_n1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgttrs_("N", &c__2, &c__1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTRFS */
s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgtrfs_("/", &c__0, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgtrfs_("N", &c_n1, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgtrfs_("N", &c__0, &c_n1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__2, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__2,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTCON */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgtcon_("/", &c__0, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgtcon_("I", &c_n1, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
r__1 = -anorm;
sgtcon_("I", &c__0, c__, d__, e, f, ip, &r__1, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PT")) {
/* Test error exits for the positive definite tridiagonal */
/* routines. */
/* SPTTRF */
s_copy(srnamc_1.srnamt, "SPTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spttrf_(&c_n1, d__, e, &info);
chkxer_("SPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTTRS */
s_copy(srnamc_1.srnamt, "SPTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spttrs_(&c_n1, &c__0, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spttrs_(&c__0, &c_n1, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spttrs_(&c__2, &c__1, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTRFS */
s_copy(srnamc_1.srnamt, "SPTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sptrfs_(&c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sptrfs_(&c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTCON */
s_copy(srnamc_1.srnamt, "SPTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sptcon_(&c_n1, d__, e, &anorm, &rcond, w, &info);
chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
r__1 = -anorm;
sptcon_(&c__0, d__, e, &r__1, &rcond, w, &info);
chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRGT */
} /* serrgt_ */
/* Subroutine */ int serrlq_(char *path, integer *nunit)
{
/* Local variables */
real a[4] /* was [2][2] */, b[2];
integer i__, j;
real w[2], x[2], af[4] /* was [2][2] */;
integer info;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRLQ tests the error exits for the REAL routines */
/* that use the LQ decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
/* L10: */
}
b[j - 1] = 0.f;
w[j - 1] = 0.f;
x[j - 1] = 0.f;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for LQ factorization */
/* SGELQF */
s_copy(srnamc_1.srnamt, "SGELQF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGELQ2 */
s_copy(srnamc_1.srnamt, "SGELQ2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGELQS */
s_copy(srnamc_1.srnamt, "SGELQS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORGLQ */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sorglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORGL2 */
s_copy(srnamc_1.srnamt, "SORGL2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorgl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorgl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORMLQ */
s_copy(srnamc_1.srnamt, "SORMLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sormlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sormlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sormlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sormlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sormlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORML2 */
s_copy(srnamc_1.srnamt, "SORML2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sorml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sorml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRLQ */
} /* serrlq_ */
/* Subroutine */ int serrps_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[16] /* was [4][4] */;
integer i__, j, piv[4], info;
real work[8];
extern /* Subroutine */ int spstf2_(char *, integer *, real *, integer *,
integer *, integer *, real *, real *, integer *), alaesm_(
char *, logical *, integer *), chkxer_(char *, integer *,
integer *, logical *, logical *), spstrf_(char *, integer
*, real *, integer *, integer *, integer *, real *, real *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRPS tests the error exits for the REAL routines */
/* for SPSTRF.. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
/* L100: */
}
piv[j - 1] = j;
work[j - 1] = 0.f;
work[j + 3] = 0.f;
/* L110: */
}
infoc_1.ok = TRUE_;
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive semidefinite matrix. */
/* SPSTRF */
s_copy(srnamc_1.srnamt, "SPSTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPSTF2 */
s_copy(srnamc_1.srnamt, "SPSTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
spstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRPS */
} /* serrps_ */
/* Subroutine */ int cerrqp_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
/* Local variables */
complex a[9] /* was [3][3] */, w[15];
char c2[2];
integer ip[3], lw;
real rw[6];
complex tau[3];
integer info;
/* Fortran I/O blocks */
static cilist io___4 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRQP tests the error exits for CGEQPF and CGEQP3. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
lw = 4;
a[0].r = 1.f, a[0].i = -1.f;
a[3].r = 2.f, a[3].i = -2.f;
a[4].r = 3.f, a[4].i = -3.f;
a[1].r = 4.f, a[1].i = -4.f;
infoc_1.ok = TRUE_;
io___4.ciunit = infoc_1.nout;
s_wsle(&io___4);
e_wsle();
/* Test error exits for QR factorization with pivoting */
if (lsamen_(&c__2, c2, "QP")) {
/* CGEQPF */
s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info);
chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info);
chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info);
chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGEQP3 */
s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info);
chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info);
chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, rw, &info);
chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
i__1 = lw - 10;
cgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info);
chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRQP */
} /* cerrqp_ */
/* Subroutine */ int cdrvrf1_(integer *nout, integer *nn, integer *nval, real
*thresh, complex *a, integer *lda, complex *arf, real *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 CLANHF ***\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;
complex q__1;
/* Local variables */
integer i__, j, n, iin, iit;
real eps;
integer info;
char norm[1], uplo[1];
integer nrun, nfail;
real large;
integer iseed[4];
char cform[1];
real small;
integer iform;
real norma;
integer inorm, iuplo, nerrs;
real result[1], 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 */
/* ======= */
/* CDRVRF1 tests the LAPACK RFP routines: */
/* CLANHF.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) 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. */
/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
/* WORK (workspace) COMPLEX 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 = slamch_("Precision");
small = slamch_("Safe minimum");
large = 1.f / 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;
clarnd_(&q__1, &c__4, iseed);
a[i__4].r = q__1.r, a[i__4].i = q__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;
q__1.r = large * a[i__5].r, q__1.i = large * a[i__5]
.i;
a[i__4].r = q__1.r, a[i__4].i = q__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;
q__1.r = small * a[i__5].r, q__1.i = small * a[i__5]
.i;
a[i__4].r = q__1.r, a[i__4].i = q__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, "CTRTTF", (ftnlen)32, (ftnlen)6);
ctrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
info);
/* Check error code from CTRTTF */
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 = clanhf_(norm, cform, uplo, &n, &arf[1], &
work[1]);
norma = clanhe_(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, "CLANHF", (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(
real));
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, "CLANHF", (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, "CLANHF", (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, "CLANHF", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of CDRVRF1 */
} /* cdrvrf1_ */
/* Subroutine */ int zerrhs_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits\002,\002 (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
doublecomplex a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
integer i__, j, m;
doublereal s[3];
doublecomplex w[9], x[3];
char c2[2];
integer nt;
doublecomplex vl[9] /* was [3][3] */, vr[9] /* was [3][3] */;
doublereal rw[3];
integer ihi, ilo;
logical sel[3];
doublecomplex tau[3];
integer info, ifaill[3];
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *), zgebal_(char *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
integer *);
integer ifailr[3];
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), chkxer_(char *, integer *, integer *,
logical *, logical *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zhseqr_(char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, 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___1 = { 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 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRHS tests the error exits for ZGEBAK, CGEBAL, CGEHRD, ZUNGHR, */
/* ZUNMHR, ZHSEQR, CHSEIN, and ZTREVC. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 3; ++j) {
for (i__ = 1; i__ <= 3; ++i__) {
i__1 = i__ + j * 3 - 4;
d__1 = 1. / (doublereal) (i__ + j);
a[i__1].r = d__1, a[i__1].i = 0.;
/* L10: */
}
sel[j - 1] = TRUE_;
/* L20: */
}
infoc_1.ok = TRUE_;
nt = 0;
/* Test error exits of the nonsymmetric eigenvalue routines. */
if (lsamen_(&c__2, c2, "HS")) {
/* ZGEBAL */
s_copy(srnamc_1.srnamt, "ZGEBAL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 3;
/* ZGEBAK */
s_copy(srnamc_1.srnamt, "ZGEBAK", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* ZGEHRD */
s_copy(srnamc_1.srnamt, "ZGEHRD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* ZUNGHR */
s_copy(srnamc_1.srnamt, "ZUNGHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* ZUNMHR */
s_copy(srnamc_1.srnamt, "ZUNMHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunmhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunmhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunmhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunmhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__2, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__2, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zunmhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zunmhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zunmhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zunmhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zunmhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 16;
/* ZHSEQR */
s_copy(srnamc_1.srnamt, "ZHSEQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zhseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zhseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zhseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zhseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zhseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zhseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zhseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zhseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, x, c__, &c__2, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zhseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, x, c__, &c__1, w, &
c__1, &info);
chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* ZHSEIN */
s_copy(srnamc_1.srnamt, "ZHSEIN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zhsein_("/", "N", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&c__0, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zhsein_("R", "/", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&c__0, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zhsein_("R", "N", "/", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&c__0, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zhsein_("R", "N", "N", sel, &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
&c__0, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zhsein_("R", "N", "N", sel, &c__2, a, &c__1, x, vl, &c__1, vr, &c__2,
&c__4, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zhsein_("L", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
&c__4, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
&c__4, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__2,
&c__1, &m, w, rw, ifaill, ifailr, &info);
chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* ZTREVC */
s_copy(srnamc_1.srnamt, "ZTREVC", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ztrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ztrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ztrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ztrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ztrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
m, w, rw, &info);
chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
}
/* Print a summary line. */
if (infoc_1.ok) {
io___22.ciunit = infoc_1.nout;
s_wsfe(&io___22);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___23.ciunit = infoc_1.nout;
s_wsfe(&io___23);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ZERRHS */
} /* zerrhs_ */
/* Subroutine */ int geoutg_(integer *iprt)
{
/* Initialized data */
static char elemnt[2*107] = " H" "He" "Li" "Be" " B" " C" " N" " O" " F"
"Ne" "Na" "Mg" "Al" "Si" " P" " S" "Cl" "Ar" " K" "Ca" "Sc" "Ti"
" V" "Cr" "Mn" "Fe" "Co" "Ni" "Cu" "Zn" "Ga" "Ge" "As" "Se" "Br"
"Kr" "Rb" "Sr" " Y" "Zr" "Nb" "Mo" "Tc" "Ru" "Rh" "Pd" "Ag" "Cd"
"In" "Sn" "Sb" "Te" " I" "Xe" "Cs" "Ba" "La" "Ce" "Pr" "Nd" "Pm"
"Sm" "Eu" "Gd" "Tb" "Dy" "Ho" "Er" "Tm" "Yb" "Lu" "Hf" "Ta" " W"
"Re" "Os" "Ir" "Pt" "Au" "Hg" "Tl" "Pb" "Bi" "Po" "At" "Rn" "Fr"
"Ra" "Ac" "Th" "Pa" " U" "Np" "Pu" "Am" "Cm" "Bk" "Cf" "XX" "Fm"
"Md" "Cb" "++" " +" "--" " -" "Tv";
static char type__[1*3] = "r" "a" "d";
/* System generated locals */
address a__1[3];
integer i__1, i__2[3], i__3, i__4;
doublereal d__1;
olist o__1;
alist al__1;
/* Builtin functions */
integer f_open(olist *);
double asin(doublereal);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_rew(alist *), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void), s_rsfe(cilist *), e_rsfe(void), s_cmp(char
*, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j, l, nbi, nci;
extern /* Subroutine */ int xxx_(char *, integer *, integer *, integer *,
integer *, char *, ftnlen, ftnlen);
static integer igeo[360] /* was [3][120] */;
static char line[15*3*120];
static integer nopt;
static char blank[80];
static doublereal degree;
static char optdat[14*360];
static integer maxtxt;
/* Fortran I/O blocks */
static cilist io___10 = { 0, 21, 0, "(F12.6)", 0 };
static cilist io___11 = { 0, 21, 0, "(F12.6)", 0 };
static cilist io___12 = { 0, 21, 0, "(A)", 0 };
static cilist io___17 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___18 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___19 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___21 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___22 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, "(A,F12.6)", 0 };
static cilist io___24 = { 0, 0, 0, "(A,F12.6)", 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 */
/* *********************************************************************** */
/* GEOUTG WRITES OUT THE GEOMETRY IN GAUSSIAN-8X STYLE */
/* *********************************************************************** */
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L10: */
igeo[j + i__ * 3 - 4] = -1;
}
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
igeo[geovar_1.loc[(i__ << 1) - 1] + geovar_1.loc[(i__ << 1) - 2] * 3
- 4] = -2;
}
i__1 = geosym_1.ndep;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geosym_1.idepfn[i__ - 1] == 14) {
igeo[geosym_1.locdep[i__ - 1] * 3 - 1] = -geosym_1.locpar[i__ - 1]
;
} else {
if (geosym_1.idepfn[i__ - 1] > 3) {
goto L30;
}
igeo[geosym_1.idepfn[i__ - 1] + geosym_1.locdep[i__ - 1] * 3 - 4]
= geosym_1.locpar[i__ - 1];
}
L30:
;
}
o__1.oerr = 0;
o__1.ounit = 21;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
degree = 90. / asin(1.);
maxtxt = *(unsigned char *)atomtx_1.ltxt;
nopt = 0;
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
s_copy(line + (j + i__ * 3 - 4) * 15, " ", (ftnlen)15, (ftnlen)1);
if (igeo[j + i__ * 3 - 4] == -1) {
al__1.aerr = 0;
al__1.aunit = 21;
f_rew(&al__1);
if (j != 1) {
s_wsfe(&io___10);
d__1 = geom_1.geo[j + i__ * 3 - 4] * degree;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
s_wsfe(&io___11);
do_fio(&c__1, (char *)&geom_1.geo[j + i__ * 3 - 4], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
al__1.aerr = 0;
al__1.aunit = 21;
f_rew(&al__1);
s_rsfe(&io___12);
do_fio(&c__1, line + (j + i__ * 3 - 4) * 15, (ftnlen)15);
e_rsfe();
} else if (igeo[j + i__ * 3 - 4] == -2) {
++nopt;
if (s_cmp(simbol_1.simbol + (nopt - 1) * 10, "---", (ftnlen)
10, (ftnlen)3) != 0) {
if (*(unsigned char *)&simbol_1.simbol[(nopt - 1) * 10] ==
'-') {
s_copy(line + ((j + i__ * 3 - 4) * 15 + 3),
simbol_1.simbol + ((nopt - 1) * 10 + 1), (
ftnlen)12, (ftnlen)9);
} else {
s_copy(line + ((j + i__ * 3 - 4) * 15 + 3),
simbol_1.simbol + (nopt - 1) * 10, (ftnlen)12,
(ftnlen)10);
}
} else {
nbi = geokst_1.nb[i__ - 1];
nci = geokst_1.nc[i__ - 1];
if (j != 3) {
nci = 0;
}
if (j == 1) {
nbi = 0;
}
xxx_(type__ + (j - 1), &i__, &geokst_1.na[i__ - 1], &nbi,
&nci, line + ((j + i__ * 3 - 4) * 15 + 3), (
ftnlen)1, (ftnlen)12);
}
s_copy(optdat + (nopt - 1) * 14, line + (j + i__ * 3 - 4) *
15, (ftnlen)14, (ftnlen)15);
} else if (igeo[j + i__ * 3 - 4] < 0) {
s_copy(line + (i__ * 3 - 1) * 15, line + (-igeo[j + i__ * 3 -
4] * 3 - 1) * 15, (ftnlen)15, (ftnlen)15);
*(unsigned char *)&line[(i__ * 3 - 1) * 15 + 2] = '-';
} else {
s_copy(line + (j + i__ * 3 - 4) * 15, line + (j + igeo[j +
i__ * 3 - 4] * 3 - 4) * 15, (ftnlen)15, (ftnlen)15);
}
/* L40: */
}
/* Writing concatenation */
i__2[0] = 2, a__1[0] = elemnt + (geokst_1.labels[i__ - 1] - 1 << 1);
i__2[1] = 8, a__1[1] = atomtx_1.txtatm + (i__ - 1 << 3);
i__2[2] = 2, a__1[2] = " ";
s_cat(blank, a__1, i__2, &c__3, (ftnlen)80);
if (geokst_1.labels[i__ - 1] == 99) {
*(unsigned char *)blank = ' ';
}
/* Computing MAX */
i__3 = 4, i__4 = maxtxt + 2;
j = max(i__3,i__4);
if (i__ == 1) {
io___17.ciunit = *iprt;
s_wsfe(&io___17);
do_fio(&c__1, blank, j);
e_wsfe();
} else if (i__ == 2) {
io___18.ciunit = *iprt;
s_wsfe(&io___18);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
e_wsfe();
} else if (i__ == 3) {
io___19.ciunit = *iprt;
s_wsfe(&io___19);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 2) * 15, (ftnlen)15);
e_wsfe();
} else {
l = 0;
io___21.ciunit = *iprt;
s_wsfe(&io___21);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 2) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nc[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 1) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&l, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L50: */
}
io___22.ciunit = *iprt;
s_wsle(&io___22);
e_wsle();
for (l = 1; l <= 3; ++l) {
i__1 = nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 1] == l) {
if (geovar_1.loc[(i__ << 1) - 1] != 1) {
io___23.ciunit = *iprt;
s_wsfe(&io___23);
do_fio(&c__1, optdat + (i__ - 1) * 14, (ftnlen)14);
d__1 = geom_1.geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3 - 4] * degree;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___24.ciunit = *iprt;
s_wsfe(&io___24);
do_fio(&c__1, optdat + (i__ - 1) * 14, (ftnlen)14);
do_fio(&c__1, (char *)&geom_1.geo[geovar_1.loc[(i__ << 1)
- 1] + geovar_1.loc[(i__ << 1) - 2] * 3 - 4], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* L60: */
}
/* L70: */
}
return 0;
} /* geoutg_ */
/* Subroutine */ int zcklse_(integer *nn, integer *mval, integer *pval,
integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
doublecomplex *bf, doublecomplex *x, doublecomplex *work, doublereal *
rwork, integer *nin, integer *nout, integer *info)
{
/* Format strings */
static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
"i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
"satisfy P <= N <= P+M \002,\002(this set of values will be skip"
"ped)\002)";
static char fmt_9999[] = "(\002 ZLATMS in ZCKLSE INFO = \002,i5)";
static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
char path[3], type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
doublereal anorm, bnorm;
integer lwork;
extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
*, integer *, char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, char *, char *),
alahdg_(integer *, char *);
doublereal cndnma, cndnmb;
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), zlarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *);
logical dotype[8];
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
logical firstt;
doublereal result[7];
extern /* Subroutine */ int zlsets_(integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCKLSE tests ZGGLSE - a subroutine for solving linear equality */
/* constrained least square problem (LSE). */
/* Arguments */
/* ========= */
/* NN (input) INTEGER */
/* The number of values of (M,P,N) contained in the vectors */
/* (MVAL, PVAL, NVAL). */
/* MVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix row(column) dimension M. */
/* PVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix row(column) dimension P. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column(row) dimension N. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* X (workspace) COMPLEX*16 array, dimension (5*NMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NIN (input) INTEGER */
/* The unit number for input. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* > 0 : If ZLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
/* Parameter adjustments */
--rwork;
--work;
--x;
--bf;
--b;
--af;
--a;
--iseed;
--nval;
--pval;
--mval;
/* Function Body */
s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
lwork = *nmax * *nmax;
/* Check for valid input values. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (p > n || n > m + p) {
if (firstt) {
io___13.ciunit = *nout;
s_wsle(&io___13);
e_wsle();
firstt = FALSE_;
}
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L10: */
}
firstt = TRUE_;
/* Do for each value of M in MVAL. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (p > n || n > m + p) {
goto L40;
}
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L30;
}
/* Set up parameters with DLATB9 and generate test */
/* matrices A and B with ZLATMS. */
dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
distb);
zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
work[1], &iinfo);
if (iinfo != 0) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
work[1], &iinfo);
if (iinfo != 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
/* Generate the right-hand sides C and D for the LSE. */
/* Computing MAX */
i__3 = m - 1;
i__2 = max(i__3,0);
/* Computing MAX */
i__5 = n - 1;
i__4 = max(i__5,0);
i__6 = max(n,1);
i__7 = max(m,1);
zlarhs_("ZGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
&c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
i__7, &iseed[1], &iinfo);
/* Computing MAX */
i__3 = p - 1;
i__2 = max(i__3,0);
/* Computing MAX */
i__5 = n - 1;
i__4 = max(i__5,0);
i__6 = max(n,1);
i__7 = max(p,1);
zlarhs_("ZGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
<< 1) + 1], &i__7, &iseed[1], &iinfo);
nt = 2;
zlsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__2 = nt;
for (i__ = 1; i__ <= i__2; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
L30:
;
}
L40:
;
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of ZCKLSE */
} /* zcklse_ */
/* Subroutine */ int sprtbr_(char *lab1, char *lab2, integer *ntypes, logical
*dotype, integer *nsizes, integer *mm, integer *nn, integer *nparms,
logical *doline, real *reslts, integer *ldr1, integer *ldr2, integer *
nout, ftnlen lab1_len, ftnlen lab2_len)
{
/* Format strings */
static char fmt_9999[] = "(7x,a4,(12(\002(\002,i4,\002,\002,i4,\002)\002"
",:)))";
static char fmt_9998[] = "(3x,a4)";
static char fmt_9997[] = "(3x,i4,4x,1p,(12(3x,g8.2)))";
static char fmt_9996[] = "(11x,1p,(12(3x,g8.2)))";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_offset, i__1, i__2, i__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j, k, iline;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
#define reslts_ref(a_1,a_2,a_3) reslts[((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
February 29, 1992
Purpose
=======
SPRTBR prints a table of timing data for the timing programs.
The table has NTYPES block rows and NSIZES columns, with NPARMS
individual rows in each block row.
Arguments (none are modified)
=========
LAB1 - CHARACTER*(*)
The label for the rows.
LAB2 - CHARACTER*(*)
The label for the columns.
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.
MM - INTEGER array of dimension( NSIZES )
The values of M used to label each column.
NN - INTEGER array of dimension( NSIZES )
The values of N used to label each column.
NPARMS - INTEGER
The number of values of LDA, hence the
number of rows for each value of DOTYPE.
DOLINE - LOGICAL array of dimension( NPARMS )
If DOLINE(i) is .TRUE., then row i (which includes data
from RESLTS( i, j, k ) for all j and k) will be printed.
If DOLINE(i) is .FALSE., then row i will not be printed.
RESLTS - REAL array of dimension( LDR1, LDR2, NSIZES )
The timing results. The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDR1 - INTEGER
The first dimension of RESLTS. It must be at least
min( 1, NPARMS ).
LDR2 - INTEGER
The second dimension of RESLTS. It must be at least
min( 1, NTYPES ).
NOUT - INTEGER
The output unit number on which the table
is to be printed. If NOUT <= 0, no output is printed.
=====================================================================
Parameter adjustments */
--dotype;
--nn;
--mm;
--doline;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * 1);
reslts -= reslts_offset;
/* Function Body */
if (*nout <= 0) {
return 0;
}
if (*nparms <= 0) {
return 0;
}
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, lab2, lab2_len);
i__1 = *nsizes;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mm[i__], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nn[i__], (ftnlen)sizeof(integer));
}
e_wsfe();
io___3.ciunit = *nout;
s_wsfe(&io___3);
do_fio(&c__1, lab1, lab1_len);
e_wsfe();
i__1 = *ntypes;
for (j = 1; j <= i__1; ++j) {
iline = 0;
if (dotype[j]) {
i__2 = *nparms;
for (i__ = 1; i__ <= i__2; ++i__) {
if (doline[i__]) {
++iline;
if (iline <= 1) {
io___6.ciunit = *nout;
s_wsfe(&io___6);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
i__3 = *nsizes;
for (k = 1; k <= i__3; ++k) {
do_fio(&c__1, (char *)&reslts_ref(i__, j, k), (
ftnlen)sizeof(real));
}
e_wsfe();
} else {
io___8.ciunit = *nout;
s_wsfe(&io___8);
i__3 = *nsizes;
for (k = 1; k <= i__3; ++k) {
do_fio(&c__1, (char *)&reslts_ref(i__, j, k), (
ftnlen)sizeof(real));
}
e_wsfe();
}
}
/* L10: */
}
if (iline > 1 && j < *ntypes) {
io___9.ciunit = *nout;
s_wsle(&io___9);
e_wsle();
}
}
/* L20: */
}
return 0;
/* End of SPRTBR */
} /* sprtbr_ */
/* Subroutine */ int derrge_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4];
integer i__, j;
doublereal w[12], x[4];
char c2[2];
doublereal r1[4], r2[4], af[16] /* was [4][4] */;
integer ip[4], iw[4], info;
doublereal anrm, ccond, rcond;
extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *),
dgetf2_(integer *, integer *, doublereal *, integer *, integer *,
integer *), dgbcon_(char *, integer *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dgecon_(char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), alaesm_(char *,
logical *, integer *), dgbequ_(integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *)
, dgbrfs_(char *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dgbtrf_(integer *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *), dgeequ_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dgerfs_(char *, integer *
, integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dgetrf_(integer *, integer *, doublereal *, integer *,
integer *, integer *), dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dgbtrs_(char *, integer *, integer *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *), dgetrs_(char *,
integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRGE tests the error exits for the DOUBLE PRECISION routines */
/* for general matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (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.;
ip[j - 1] = j;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GE")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general matrix. */
/* DGETRF */
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETF2 */
s_copy(srnamc_1.srnamt, "DGETF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRI */
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGETRS */
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGERFS */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGECON */
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGEEQU */
s_copy(srnamc_1.srnamt, "DGEEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "GB")) {
/* Test error exits of the routines that use the LU decomposition */
/* of a general band matrix. */
/* DGBTRF */
s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTF2 */
s_copy(srnamc_1.srnamt, "DGBTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBTRS */
s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBRFS */
s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
c__2, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__2, x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBCON */
s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
&info);
chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGBEQU */
s_copy(srnamc_1.srnamt, "DGBEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRGE */
} /* derrge_ */
/* Subroutine */ int zerrlq_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublecomplex a[4] /* was [2][2] */, b[2];
integer i__, j;
doublecomplex w[2], x[2], af[4] /* was [2][2] */;
integer info;
extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zungl2_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zunml2_(char *,
char *, integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
*), zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zgelqs_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), zunglq_(integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), zunmlq_(char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRLQ tests the error exits for the COMPLEX*16 routines */
/* that use the LQ decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
i__1 = i__ + (j << 1) - 3;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = i__ + (j << 1) - 3;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
af[i__1].r = z__1.r, af[i__1].i = z__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = j - 1;
w[i__1].r = 0., w[i__1].i = 0.;
i__1 = j - 1;
x[i__1].r = 0., x[i__1].i = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for LQ factorization */
/* ZGELQF */
s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGELQ2 */
s_copy(srnamc_1.srnamt, "ZGELQ2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGELQS */
s_copy(srnamc_1.srnamt, "ZGELQS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNGLQ */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNGL2 */
s_copy(srnamc_1.srnamt, "ZUNGL2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zungl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zungl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNMLQ */
s_copy(srnamc_1.srnamt, "ZUNMLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunmlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunmlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunmlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunmlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunmlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNML2 */
s_copy(srnamc_1.srnamt, "ZUNML2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of ZERRLQ */
} /* zerrlq_ */
/* Subroutine */ int derrsy_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal anrm, a[16] /* was [4][4] */, b[4];
static integer i__, j;
static doublereal w[12], x[4], rcond;
static char c2[2];
static doublereal r1[4], r2[4], af[16] /* was [4][4] */;
extern /* Subroutine */ int dsytf2_(char *, integer *, doublereal *,
integer *, integer *, integer *);
static integer ip[4], iw[4];
extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dspcon_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dsycon_(char *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dsprfs_(char *, integer *, integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, integer *, integer *), dsptrf_(char *, integer *,
doublereal *, integer *, integer *), dsptri_(char *,
integer *, doublereal *, integer *, doublereal *, integer *), dsyrfs_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dsytrf_(char *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dsytri_(char *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *), dsptrs_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *), dsytrs_(
char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
#define af_ref(a_1,a_2) af[(a_2)*4 + a_1 - 5]
/* -- LAPACK test 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
=======
DERRSY tests the error exits for the DOUBLE PRECISION routines
for symmetric indefinite matrices.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 1. / (doublereal) (i__ + j);
af_ref(i__, j) = 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.;
ip[j - 1] = j;
iw[j - 1] = j;
/* L20: */
}
anrm = 1.;
rcond = 1.;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "SY")) {
/* Test error exits of the routines that use the Bunch-Kaufman
factorization of a symmetric indefinite matrix.
DSYTRF */
s_copy(srnamc_1.srnamt, "DSYTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsytrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsytrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dsytrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSYTF2 */
s_copy(srnamc_1.srnamt, "DSYTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsytf2_("/", &c__0, a, &c__1, ip, &info);
chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsytf2_("U", &c_n1, a, &c__1, ip, &info);
chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dsytf2_("U", &c__2, a, &c__1, ip, &info);
chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSYTRI */
s_copy(srnamc_1.srnamt, "DSYTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsytri_("/", &c__0, a, &c__1, ip, w, &info);
chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsytri_("U", &c_n1, a, &c__1, ip, w, &info);
chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dsytri_("U", &c__2, a, &c__1, ip, w, &info);
chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSYTRS */
s_copy(srnamc_1.srnamt, "DSYTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsytrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsytrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dsytrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dsytrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dsytrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSYRFS */
s_copy(srnamc_1.srnamt, "DSYRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsyrfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsyrfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dsyrfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dsyrfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSYCON */
s_copy(srnamc_1.srnamt, "DSYCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsycon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsycon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dsycon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dsycon_("U", &c__1, a, &c__1, ip, &c_b152, &rcond, w, iw, &info);
chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "SP")) {
/* Test error exits of the routines that use the Bunch-Kaufman
factorization of a symmetric indefinite packed matrix.
DSPTRF */
s_copy(srnamc_1.srnamt, "DSPTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsptrf_("/", &c__0, a, ip, &info);
chkxer_("DSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsptrf_("U", &c_n1, a, ip, &info);
chkxer_("DSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSPTRI */
s_copy(srnamc_1.srnamt, "DSPTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsptri_("/", &c__0, a, ip, w, &info);
chkxer_("DSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsptri_("U", &c_n1, a, ip, w, &info);
chkxer_("DSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSPTRS */
s_copy(srnamc_1.srnamt, "DSPTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dsptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dsptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSPRFS */
s_copy(srnamc_1.srnamt, "DSPRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dsprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dsprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
iw, &info);
chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DSPCON */
s_copy(srnamc_1.srnamt, "DSPCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dspcon_("/", &c__0, a, ip, &anrm, &rcond, w, iw, &info);
chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dspcon_("U", &c_n1, a, ip, &anrm, &rcond, w, iw, &info);
chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dspcon_("U", &c__1, a, ip, &c_b152, &rcond, w, iw, &info);
chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRSY */
} /* derrsy_ */
/* Subroutine */ int dtimql_(char *line, integer *nm, integer *mval, integer *
nval, integer *nk, integer *kval, integer *nnb, integer *nbval,
integer *nxval, integer *nlda, integer *ldaval, doublereal *timmin,
doublereal *a, doublereal *tau, doublereal *b, doublereal *work,
doublereal *reslts, integer *ldr1, integer *ldr2, integer *ldr3,
integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*3] = "DGEQLF" "DORGQL" "DORMQL";
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_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);
extern /* Subroutine */ int dgeqlf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
static integer lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen), dlacpy_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), dtimmg_(
integer *, integer *, integer *, doublereal *, integer *, integer
*, integer *), dlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dorgql_(integer *, integer
*, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *), dormql_(char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *);
static doublereal untime;
static logical timsub[3];
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
=======
DTIMQL times the LAPACK routines to perform the QL factorization of
a DOUBLE PRECISION 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 DORMQL.
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) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
B (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
WORK (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
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 DLATMS 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;
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, "Double precision", (ftnlen)1, (ftnlen)16);
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);
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &tau[1], &c__3, &
c_b24, &c_b25, &m, &n, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[0]) {
/* DGEQLF: QL factorization */
dlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = dsecnd_();
L10:
dgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
dlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in DLACPY. */
icl = 1;
s1 = dsecnd_();
L20:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
dlacpy_("Full", &m, &n, &a[1], &lda, &b[1], &lda);
goto L20;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("DGEQLF", &m, &n, &c__0, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = dmflop_(&ops, &time, &info)
;
} else {
/* If DGEQLF was not timed, generate a matrix and factor
it using DGEQLF anyway so that the factored form of
the matrix can be used in timing the other routines. */
dlacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
dgeqlf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
}
if (timsub[1]) {
/* DORGQL: Generate orthogonal matrix Q from the QL
factorization */
dlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = dsecnd_();
L30:
dorgql_(&m, &minmn, &minmn, &b[1], &lda, &tau[1], &work[1]
, &lw, &info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
dlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L30;
}
/* Subtract the time used in DLACPY. */
icl = 1;
s1 = dsecnd_();
L40:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
dlacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("DORGQL", &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 DORMQL 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: */
}
/* DORMQL: 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. */
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &tau[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);
dgeqlf_(&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];
dtimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = dsecnd_();
L110:
dormql_(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) {
dtimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L110;
}
/* Subtract the time used in DTIMMG. */
icl = 1;
s1 = dsecnd_();
L120:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
dtimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L120;
}
time = (time - untime) / (doublereal) ic;
i__5 = iside - 1;
ops = dopla_("DORMQL", &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 DTIMQL */
} /* dtimql_ */
/* Subroutine */ int deriv_(doublereal *geo, doublereal *grad)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), f_open(olist *), f_rew(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double pow_di(doublereal *, integer *), sqrt(doublereal);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j;
static logical ci;
static integer ii, ij, il, jl, kl, ll, kk;
static logical aic;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static logical int__;
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sum;
static logical scf1;
static char line[80];
static integer ncol;
static doublereal xjuc[3], step;
static logical slow;
static integer icapa;
static logical halfe, debug;
extern /* Subroutine */ int dcart_(doublereal *, doublereal *);
static integer iline;
static logical geook;
static doublereal grlim;
static integer ilowa;
static doublereal gnorm;
extern /* Subroutine */ int geout_(integer *);
static integer ilowz;
static doublereal change[3], aidref[360];
static integer idelta;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static logical precis, noanci, aifrst;
extern /* Subroutine */ int dernvo_(doublereal *, doublereal *), jcarin_(
doublereal *, doublereal *, doublereal *, logical *, doublereal *,
integer *), gmetry_(doublereal *, doublereal *), deritr_(
doublereal *, doublereal *), symtry_(void);
/* Fortran I/O blocks */
static cilist io___14 = { 0, 5, 0, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___21 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___22 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___25 = { 1, 5, 1, 0, 0 };
static cilist io___26 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___27 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___29 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___32 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___37 = { 0, 6, 0, "(' GEO AT START OF DERIV')", 0 };
static cilist io___38 = { 0, 6, 0, "(F19.5,2F12.5)", 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, "(//,3(A,/),I3,A)", 0 };
static cilist io___55 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, "(' GRADIENTS')", 0 };
static cilist io___58 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___59 = { 0, 6, 0, "(' ERROR FUNCTION')", 0 };
static cilist io___60 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___61 = { 0, 6, 0, "(' COSINE OF SEARCH DIRECTION =',F30"
".6)", 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 */
/* *********************************************************************** */
/* DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE */
/* INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES. */
/* THE MAIN ARRAYS IN DERIV ARE: */
/* LOC INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM */
/* INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE */
/* DERIVATIVE CALCULATION. */
/* GEO ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES. */
/* GRAD ON EXIT, CONTAINS THE DERIVATIVES */
/* *********************************************************************** */
/* Parameter adjustments */
--grad;
geo -= 4;
/* Function Body */
if (icalcn != numcal_1.numcal) {
aifrst = i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) ==
0;
debug = i_indx(keywrd_1.keywrd, "DERIV", (ftnlen)241, (ftnlen)5) != 0;
precis = i_indx(keywrd_1.keywrd, "PREC", (ftnlen)241, (ftnlen)4) != 0;
int__ = i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0;
geook = i_indx(keywrd_1.keywrd, "GEO-OK", (ftnlen)241, (ftnlen)6) !=
0;
ci = i_indx(keywrd_1.keywrd, "C.I.", (ftnlen)241, (ftnlen)4) != 0;
scf1 = i_indx(keywrd_1.keywrd, "1SCF", (ftnlen)241, (ftnlen)4) != 0;
aic = i_indx(keywrd_1.keywrd, "AIDER", (ftnlen)241, (ftnlen)5) != 0;
icapa = 'A';
ilowa = 'a';
ilowz = 'z';
if (aic && aifrst) {
o__1.oerr = 0;
o__1.ounit = 5;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR005", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = "ZERO";
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 5;
f_rew(&al__1);
/* ISOK IS SET FALSE: ONLY ONE SYSTEM ALLOWED */
okmany_1.isok = FALSE_;
for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
s_rsfe(&io___14);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
}
for (j = 1; j <= 1000; ++j) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= ilowa && iline <= ilowz) {
*(unsigned char *)&line[i__ - 1] = (char) (iline +
icapa - ilowa);
}
/* L20: */
}
/* *********************************************************************** */
/* L30: */
if (i_indx(line, "AIDER", (ftnlen)80, (ftnlen)5) != 0) {
goto L60;
}
}
L40:
s_wsfe(&io___19);
do_fio(&c__1, " KEYWORD \"AIDER\" SPECIFIED, BUT NOT", (ftnlen)35)
;
e_wsfe();
s_wsfe(&io___20);
do_fio(&c__1, " PRESENT AFTER Z-MATRIX. JOB STOPPED", (ftnlen)37)
;
e_wsfe();
s_stop("", (ftnlen)0);
L50:
s_wsfe(&io___21);
do_fio(&c__1, " FAULT IN READ OF AB INITIO DERIVATIVES", (ftnlen)
40);
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, " DERIVATIVES READ IN ARE AS FOLLOWS", (ftnlen)36);
e_wsfe();
s_wsfe(&io___23);
i__1 = i__;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_stop("", (ftnlen)0);
L60:
if (geokst_1.natoms > 2) {
j = geokst_1.natoms * 3 - 6;
} else {
j = 1;
}
i__1 = s_rsle(&io___25);
if (i__1 != 0) {
goto L50;
}
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_lio(&c__5, &c__1, (char *)&aidref[i__ - 1], (ftnlen)
sizeof(doublereal));
if (i__1 != 0) {
goto L50;
}
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L50;
}
s_wsfe(&io___26);
do_fio(&c__1, " AB-INITIO DERIVATIVES IN KCAL/MOL/(ANGSTROM OR R"
"ADIAN)", (ftnlen)55);
e_wsfe();
s_wsfe(&io___27);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 2] > 3) {
j = geovar_1.loc[(i__ << 1) - 2] * 3 + geovar_1.loc[(i__
<< 1) - 1] - 9;
} else if (geovar_1.loc[(i__ << 1) - 2] == 3) {
j = geovar_1.loc[(i__ << 1) - 1] + 1;
} else {
j = 1;
}
/* L70: */
aidref[i__ - 1] = aidref[j - 1];
}
s_wsfe(&io___28);
do_fio(&c__1, " AB-INITIO DERIVATIVES FOR VARIABLES", (ftnlen)36);
e_wsfe();
s_wsfe(&io___29);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
if (geosym_1.ndep != 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = aidref[i__ - 1];
i__2 = geosym_1.ndep;
for (j = 1; j <= i__2; ++j) {
if (geovar_1.loc[(i__ << 1) - 2] == geosym_1.locpar[j
- 1] && (geovar_1.loc[(i__ << 1) - 1] ==
geosym_1.idepfn[j - 1] || geovar_1.loc[(i__ <<
1) - 1] == 3 && geosym_1.idepfn[j - 1] == 14)
) {
aidref[i__ - 1] += sum;
}
/* L80: */
}
/* L90: */
}
s_wsfe(&io___31);
do_fio(&c__1, " AB-INITIO DERIVATIVES AFTER SYMMETRY WEIGHTI"
"NG", (ftnlen)47);
e_wsfe();
s_wsfe(&io___32);
i__1 = geovar_1.nvar;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
icalcn = numcal_1.numcal;
if (i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) == 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
errfn_1.errfn[i__ - 1] = 0.;
}
}
grlim = .01;
if (precis) {
grlim = 1e-4;
}
halfe = molkst_1.nopen > molkst_1.nclose && molkst_1.fract != 2. &&
molkst_1.fract != 0. || ci;
idelta = -7;
/* IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER */
change[0] = pow_di(&c_b70, &idelta);
change[1] = pow_di(&c_b70, &idelta);
change[2] = pow_di(&c_b70, &idelta);
/* CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES. */
/* FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN */
/* INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE */
/* HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF */
/* CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL */
/* ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND */
/* DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO */
/* FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH, */
/* (2) FOR ANGLE, AND (3) FOR DIHEDRAL. */
}
if (geovar_1.nvar == 0) {
return 0;
}
if (debug) {
s_wsfe(&io___37);
e_wsfe();
s_wsfe(&io___38);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_fio(&c__1, (char *)&geo[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_wsfe();
}
gnorm = 0.;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
genral_1.gold[i__ - 1] = grad[i__];
genral_1.xparam[i__ - 1] = geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3];
/* L110: */
/* Computing 2nd power */
d__1 = grad[i__];
gnorm += d__1 * d__1;
}
gnorm = sqrt(gnorm);
slow = FALSE_;
noanci = FALSE_;
if (halfe) {
noanci = i_indx(keywrd_1.keywrd, "NOANCI", (ftnlen)241, (ftnlen)6) !=
0 || molkst_1.nopen == molkst_1.norbs;
slow = noanci && (gnorm < grlim || scf1);
}
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], genral_1.coord);
/* COORD NOW HOLDS THE CARTESIAN COORDINATES */
if (halfe && ! noanci) {
if (debug) {
s_wsle(&io___42);
do_lio(&c__9, &c__1, "DOING ANALYTICAL C.I. DERIVATIVES", (ftnlen)
33);
e_wsle();
}
dernvo_(genral_1.coord, xyzgra_1.dxyz);
} else {
if (debug) {
s_wsle(&io___43);
do_lio(&c__9, &c__1, "DOING VARIATIONALLY OPIMIZED DERIVATIVES", (
ftnlen)40);
e_wsle();
}
dcart_(genral_1.coord, xyzgra_1.dxyz);
}
ij = 0;
i__1 = molkst_1.numat;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ucell_1.l1u;
for (il = ucell_1.l1l; il <= i__2; ++il) {
i__3 = ucell_1.l2u;
for (jl = ucell_1.l2l; jl <= i__3; ++jl) {
i__4 = ucell_1.l3u;
for (kl = ucell_1.l3l; kl <= i__4; ++kl) {
/* $DOIT ASIS */
for (ll = 1; ll <= 3; ++ll) {
/* L120: */
xjuc[ll - 1] = genral_1.coord[ll + ii * 3 - 4] +
euler_1.tvec[ll - 1] * il + euler_1.tvec[ll +
2] * jl + euler_1.tvec[ll + 5] * kl;
}
++ij;
/* $DOIT ASIS */
for (kk = 1; kk <= 3; ++kk) {
genral_1.cold[kk + ij * 3 - 4] = xjuc[kk - 1];
/* L130: */
}
/* L140: */
}
}
}
/* L150: */
}
step = change[0];
jcarin_(genral_1.coord, genral_1.xparam, &step, &precis, work3_1.work2, &
ncol);
mxm_(work3_1.work2, &geovar_1.nvar, xyzgra_1.dxyz, &ncol, &grad[1], &c__1)
;
if (precis) {
step = .5 / step;
} else {
step = 1. / step;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L160: */
grad[i__] *= step;
}
/* NOW TO ENSURE THAT INTERNAL DERIVATIVES ACCURATELY REFLECT CARTESIAN */
/* DERIVATIVES */
if (int__ && ! geook && geovar_1.nvar >= molkst_1.numat * 3 - 6 &&
euler_1.id == 0) {
/* NUMBER OF VARIABLES LOOKS O.K. */
sum = dot_(&grad[1], &grad[1], &geovar_1.nvar);
i__1 = molkst_1.numat * 3;
/* Computing MAX */
d__1 = 4., d__2 = sum * 4.;
if (sum < 2. && dot_(xyzgra_1.dxyz, xyzgra_1.dxyz, &i__1) > max(d__1,
d__2)) {
/* OOPS, LOOKS LIKE AN ERROR. */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = (integer) (genral_1.xparam[i__ - 1] / 3.141);
if (geovar_1.loc[(i__ << 1) - 1] == 2 && geovar_1.loc[(i__ <<
1) - 2] > 3 && (d__1 = genral_1.xparam[i__ - 1] - j *
3.1415926, abs(d__1)) < .005) {
/* ERROR LOCATED, BUT CANNOT CORRECT IN THIS RUN */
s_wsfe(&io___54);
do_fio(&c__1, " INTERNAL COORDINATE DERIVATIVES DO NOT R"
"EFLECT", (ftnlen)47);
do_fio(&c__1, " CARTESIAN COORDINATE DERIVATIVES", (
ftnlen)33);
do_fio(&c__1, " TO CORRECT ERROR, INCREASE DIHEDRAL OF A"
"TOM", (ftnlen)44);
do_fio(&c__1, (char *)&geovar_1.loc[(i__ << 1) - 2], (
ftnlen)sizeof(integer));
do_fio(&c__1, " BY 90 DEGREES", (ftnlen)14);
e_wsfe();
s_wsfe(&io___55);
do_fio(&c__1, " CURRENT GEOMETRY", (ftnlen)21);
e_wsfe();
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L170: */
}
}
}
/* THIS CODE IS ONLY USED IF THE KEYWORD NOANCI IS SPECIFIED */
if (slow) {
if (debug) {
s_wsle(&io___56);
do_lio(&c__9, &c__1, "DOING FULL SCF DERIVATIVES", (ftnlen)26);
e_wsle();
}
deritr_(errfn_1.errfn, &geo[4]);
/* THE ARRAY ERRFN HOLDS THE EXACT DERIVATIVES MINUS THE APPROXIMATE */
/* DERIVATIVES */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L180: */
errfn_1.errfn[i__ - 1] -= grad[i__];
}
}
gravec_1.cosine = dot_(&grad[1], genral_1.gold, &geovar_1.nvar) / sqrt(
dot_(&grad[1], &grad[1], &geovar_1.nvar) * dot_(genral_1.gold,
genral_1.gold, &geovar_1.nvar) + 1e-20);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L190: */
grad[i__] += errfn_1.errfn[i__ - 1];
}
if (aic) {
if (aifrst) {
aifrst = FALSE_;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L200: */
errfn_1.aicorr[i__ - 1] = -aidref[i__ - 1] - grad[i__];
}
}
/* # WRITE(6,'('' GRADIENTS BEFORE AI CORRECTION'')') */
/* # WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR) */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L210: */
grad[i__] += errfn_1.aicorr[i__ - 1];
}
}
/* L220: */
if (debug) {
s_wsfe(&io___57);
e_wsfe();
s_wsfe(&io___58);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&grad[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
if (slow) {
s_wsfe(&io___59);
e_wsfe();
s_wsfe(&io___60);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&errfn_1.errfn[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
if (debug) {
s_wsfe(&io___61);
do_fio(&c__1, (char *)&gravec_1.cosine, (ftnlen)sizeof(doublereal));
e_wsfe();
}
return 0;
} /* deriv_ */
/* Subroutine */ int cckglm_(integer *nn, integer *nval, integer *mval,
integer *pval, integer *nmats, integer *iseed, real *thresh, integer *
nmax, complex *a, complex *af, complex *b, complex *bf, complex *x,
complex *work, real *rwork, integer *nin, integer *nout, integer *
info)
{
/* Format strings */
static char fmt_9997[] = "(\002 *** Invalid input for GLM: M = \002,"
"i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
"satisfy M <= N <= M+P \002,\002(this set of values will be skip"
"ped)\002)";
static char fmt_9999[] = "(\002 CLATMS in CCKGLM INFO = \002,i5)";
static char fmt_9998[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, m, n, p, ik, lda, ldb, kla, klb, kua, kub, imat;
char path[3], type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
real resid, anorm, bnorm;
integer lwork;
extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
*, integer *, char *, integer *, integer *, integer *, integer *,
real *, real *, integer *, integer *, real *, real *, char *,
char *), alahdg_(integer *, char *
);
real cndnma, cndnmb;
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), clatms_(integer *,
integer *, char *, integer *, char *, real *, integer *, real *,
real *, integer *, integer *, char *, complex *, integer *,
complex *, integer *), cglmts_(integer *,
integer *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, complex *, complex *, complex *, complex *,
complex *, integer *, real *, real *);
logical dotype[8], firstt;
/* Fortran I/O blocks */
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 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 */
/* ======= */
/* CCKGLM tests CGGGLM - subroutine for solving generalized linear */
/* model problem. */
/* Arguments */
/* ========= */
/* NN (input) INTEGER */
/* The number of values of N, M and P contained in the vectors */
/* NVAL, MVAL and PVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix row dimension N. */
/* MVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension M. */
/* PVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension P. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESID >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* BF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* X (workspace) COMPLEX array, dimension (4*NMAX) */
/* RWORK (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* NIN (input) INTEGER */
/* The unit number for input. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* > 0 : If CLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants. */
/* Parameter adjustments */
--rwork;
--work;
--x;
--bf;
--b;
--af;
--a;
--iseed;
--pval;
--mval;
--nval;
/* Function Body */
s_copy(path, "GLM", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
lwork = *nmax * *nmax;
/* Check for valid input values. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (m > n || n > m + p) {
if (firstt) {
io___13.ciunit = *nout;
s_wsle(&io___13);
e_wsle();
firstt = FALSE_;
}
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L10: */
}
firstt = TRUE_;
/* Do for each value of M in MVAL. */
i__1 = *nn;
for (ik = 1; ik <= i__1; ++ik) {
m = mval[ik];
p = pval[ik];
n = nval[ik];
if (m > n || n > m + p) {
goto L40;
}
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L30;
}
/* Set up parameters with SLATB9 and generate test */
/* matrices A and B with CLATMS. */
slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
distb);
clatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &modea, &
cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
work[1], &iinfo);
if (iinfo != 0) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
clatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &modeb, &
cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
work[1], &iinfo);
if (iinfo != 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L30;
}
/* Generate random left hand side vector of GLM */
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
clarnd_(&q__1, &c__2, &iseed[1]);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L20: */
}
cglmts_(&n, &m, &p, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
, &work[1], &lwork, &rwork[1], &resid);
/* Print information about the tests that did not */
/* pass the threshold. */
if (resid >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
L30:
;
}
L40:
;
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of CCKGLM */
} /* cckglm_ */
/* Subroutine */ int zerrab_(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)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* 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 */
doublecomplex a[16] /* was [4][4] */, b[4], c__[4];
integer i__, j;
doublecomplex r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4]
*/;
integer ip[4], info, iter;
doublecomplex work[1];
doublereal rwork[1];
complex swork[1];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), zcgesv_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, complex *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRAB tests the error exits for ZCGESV. */
/* Arguments */
/* ========= */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
d__1 = 1. / (doublereal) (i__ + j);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = i__ + (j << 2) - 5;
d__1 = 1. / (doublereal) (i__ + j);
af[i__1].r = d__1, af[i__1].i = 0.;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = j - 1;
r1[i__1].r = 0., r1[i__1].i = 0.;
i__1 = j - 1;
r2[i__1].r = 0., r2[i__1].i = 0.;
i__1 = j - 1;
w[i__1].r = 0., w[i__1].i = 0.;
i__1 = j - 1;
x[i__1].r = 0., x[i__1].i = 0.;
i__1 = j - 1;
c__[i__1].r = 0., c__[i__1].i = 0.;
i__1 = j - 1;
r__[i__1].r = 0., r__[i__1].i = 0.;
ip[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
s_copy(srnamc_1.srnamt, "ZCGESV", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zcgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zcgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zcgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, x, &c__2, work, swork,
rwork, &iter, &info);
chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zcgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, x, &c__2, work, swork,
rwork, &iter, &info);
chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zcgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__2, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
if (infoc_1.ok) {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, "ZCGESV", (ftnlen)6);
e_wsfe();
} else {
io___20.ciunit = infoc_1.nout;
s_wsfe(&io___20);
do_fio(&c__1, "ZCGESV", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of ZERRAB */
} /* zerrab_ */
/* Subroutine */ int dtimqp_(char *line, integer *nm, integer *mval, integer *
nval, integer *nlda, integer *ldaval, doublereal *timmin, doublereal *
a, doublereal *copya, doublereal *tau, doublereal *work, integer *
iwork, doublereal *reslts, integer *ldr1, integer *ldr2, integer *
nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*1] = "DGEQPF";
static integer modes[2] = { 2,3 };
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)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_offset, i__1, i__2, i__3;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda;
static doublereal cond;
static integer mode;
static doublereal dmax__;
static integer info;
static char path[3];
static doublereal time;
static integer i__, m, n;
static char cname[6];
static integer imode;
extern doublereal dopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer minmn;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static doublereal s1, s2;
extern /* Subroutine */ int dprtb5_(char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, integer *, integer *, ftnlen, ftnlen, ftnlen);
static integer ic, im;
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int dgeqpf_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *),
atimck_(integer *, char *, integer *, integer *, integer *,
integer *, integer *, integer *, ftnlen), dlacpy_(char *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dmflop_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen), dlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublereal *, integer *, doublereal *, integer *);
static doublereal untime;
static logical timsub[1];
static integer lda, icl;
static doublereal ops;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, 0, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3) reslts[((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
June 30, 1999
Purpose
=======
DTIMQP times the LAPACK routines to perform the QR factorization with
column pivoting of a DOUBLE PRECISION general matrix.
Two matrix types may be used for timing. The number of types is
set in the parameter NMODE and the matrix types are set in the vector
MODES, using the following key:
2. BREAK1 D(1:N-1)=1 and D(N)=1.0/COND in DLATMS
3. GEOM D(I)=COND**(-(I-1)/(N-1)) in DLATMS
These numbers are chosen to correspond with the matrix types in the
test code.
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.
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) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
COPYA (workspace) DOUBLE PRECISION array, dimension (LDAMAX*NMAX)
TAU (workspace) DOUBLE PRECISION array, dimension (min(M,N))
WORK (workspace) DOUBLE PRECISION array, dimension (3*NMAX)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
RESLTS (workspace) DOUBLE PRECISION array, dimension
(LDR1,LDR2,NLDA)
The timing results for each subroutine over the relevant
values of MODE, (M,N), and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NM).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--ldaval;
--a;
--copya;
--tau;
--work;
--iwork;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * 1);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__1, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (! timsub[0] || info != 0) {
goto L80;
}
/* 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___8.ciunit = *nout;
s_wsfe(&io___8);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L80;
}
/* Set the condition number and scaling factor for the matrices
to be generated. */
dmax__ = 1.;
cond = 1. / dlamch_("Precision");
/* 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);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
for (imode = 1; imode <= 2; ++imode) {
mode = modes[imode - 1];
/* Generate a test matrix of size m by n using the
singular value distribution indicated by MODE. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[n + i__] = 0;
/* L10: */
}
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &tau[1], &mode, &
cond, &dmax__, &m, &n, "No packing", ©a[1], &lda,
&work[1], &info);
/* DGEQPF: QR factorization with column pivoting */
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[n + 1], &c__1, &iwork[1], &c__1);
ic = 0;
s1 = dsecnd_();
L20:
dgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
info);
s2 = dsecnd_();
time = s2 - s1;
++ic;
if (time < *timmin) {
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[n + 1], &c__1, &iwork[1], &c__1);
goto L20;
}
/* Subtract the time used in DLACPY and ICOPY. */
icl = 1;
s1 = dsecnd_();
L30:
s2 = dsecnd_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[n + 1], &c__1, &iwork[1], &c__1);
goto L30;
}
time = (time - untime) / (doublereal) ic;
ops = dopla_("DGEQPF", &m, &n, &c__0, &c__0, &c__1)
;
reslts_ref(imode, im, ilda) = dmflop_(&ops, &time, &info);
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Print tables of results */
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, subnam_ref(0, 1), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L70: */
}
}
io___29.ciunit = *nout;
s_wsle(&io___29);
e_wsle();
dprtb5_("Type", "M", "N", &c__2, modes, nm, &mval[1], &nval[1], nlda, &
reslts[reslts_offset], ldr1, ldr2, nout, (ftnlen)4, (ftnlen)1, (
ftnlen)1);
L80:
return 0;
/* End of DTIMQP */
} /* dtimqp_ */
/* Subroutine */ int derrab_(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)";
/* 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 ip[4], info, iter;
doublereal work[1];
real swork[1];
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRAB tests the error exits for DSGESV. */
/* 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.;
ip[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
s_copy(srnamc_1.srnamt, "DSGESV", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dsgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dsgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, x, &c__2, work, swork, &
iter, &info);
chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dsgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, x, &c__2, work, swork, &
iter, &info);
chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dsgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__2, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
if (infoc_1.ok) {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, "DSGESV", (ftnlen)6);
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, "DSGESV", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of DERRAB */
} /* derrab_ */
/* $Procedure META_2 ( Percy's interface to META_0 ) */
/* Subroutine */ int meta_2__0_(int n__, char *command, char *temps, integer *
ntemps, char *temp, integer *btemp, char *error, ftnlen command_len,
ftnlen temps_len, ftnlen temp_len, ftnlen error_len)
{
/* Initialized data */
static logical pass1 = TRUE_;
static char margns[128] = "LEFT 1 RIGHT 75 "
" "
" ";
static char keynam[6*10] = "1 " "2 " "3 " "4 " "5 "
"6 " "7 " "8 " "9 " "10 ";
/* System generated locals */
address a__1[5];
integer i__1, i__2[5];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle(
void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int getopt_1__(char *, integer *, char *, integer
*, char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen, ftnlen);
static integer sbeg;
static char mode[16], pick[32];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
extern logical batch_(void);
static integer score;
static logical fixit;
extern integer rtrim_(char *, ftnlen);
static char style[128];
static integer m2code;
static char tryit[600];
extern /* Subroutine */ int m2gmch_(char *, char *, char *, integer *,
logical *, integer *, logical *, integer *, integer *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), m2rcvr_(integer *, integer *,
char *, ftnlen), scardc_(integer *, char *, ftnlen);
static integer bscore, cutoff;
static logical reason;
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen), ssizec_(integer *, char *, ftnlen), repsub_(char *,
integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static logical intrct;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
static char thnwds[32*7], kwords[32*16];
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), prepsn_(char *, ftnlen);
static logical pssthn;
static char questn[80];
extern /* Subroutine */ int niceio_3__(char *, integer *, char *, ftnlen,
ftnlen), cnfirm_1__(char *, logical *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Given a collection of acceptable syntax's and a statement */
/* (COMMAND) this routine determines if the statement is */
/* syntactically correct. */
/* $ 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 */
/* The META/2 Book. */
/* $ Keywords */
/* COMPARE */
/* PARSING */
/* SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMAND I A candidate PERCY command. */
/* TEMPS I A collection of language definition statements */
/* NTEMPS I The number of definition statements */
/* TEMP - Work space required for comparison of statements. */
/* BTEMP O The first of the def statements that best matches. */
/* ERROR O Non-blank if none of the def's match. */
/* $ Detailed_Input */
/* COMMAND A candidate PERCY command. */
/* TEMPS A collection of language definition statements */
/* NTEMPS The number of definition statements */
/* TEMP Work space required for comparison of statements. */
/* TEMP should be declared to have the same length */
/* as the character strings that make up TEMPS. */
/* $ Detailed_Output */
/* BTEMP The first of the def statements that best matches. */
/* ERROR Non-blank if none of the def's match. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* Later. */
/* $ Examples */
/* Later. */
/* $ Restrictions */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 3.0.0, 11-AUG-1995 (WLT) */
/* The control flow through this routine was modified */
/* so that it will now re-try all templates (starting */
/* with the best previous match) if a spelling error */
/* is encountered. This should fix the confused */
/* responses that META/2 gave occassionally before. */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 */
/* Added a pretty print formatting capability to the */
/* error diagnostics. */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* - Beta Version 2.0.0, 14-JAN-1993 (HAN) */
/* Assigned the value 'INTERACTIVE' to the variable MODE, and */
/* replaced calls to VTLIB routines with calls to more */
/* portable routines. */
/* - Beta Version 1.0.0, 13-JUL-1988 (WLT) (IMU) */
/* -& */
/* Spice Functions */
/* Local variables. */
/* Saved variables */
/* Initial values */
/* Parameter adjustments */
if (temps) {
}
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_m2marg;
}
/* %&END_DECLARATIONS */
/* Take care of first pass initializations. */
if (pass1) {
pass1 = FALSE_;
ssizec_(&c__1, thnwds, (ftnlen)32);
scardc_(&c__0, thnwds, (ftnlen)32);
ssizec_(&c__10, kwords, (ftnlen)32);
scardc_(&c__0, kwords, (ftnlen)32);
/* Determine if were in batch or interactive mode. */
if (batch_()) {
s_copy(mode, "BATCH", (ftnlen)16, (ftnlen)5);
} else {
s_copy(mode, "INTERACTIVE", (ftnlen)16, (ftnlen)11);
}
}
intrct = s_cmp(mode, "BATCH", (ftnlen)16, (ftnlen)5) != 0;
s_copy(style, margns, (ftnlen)128, (ftnlen)128);
suffix_("NEWLINE /cr VTAB /vt HARDSPACE , ", &c__1, style, (ftnlen)33, (
ftnlen)128);
i__ = 0;
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
/* Look through the templates until we get a match or we */
/* run out of templates to try. */
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
score = 0;
s_copy(temp, temps + (i__ - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
/* If M2CODE comes back zero, we are done with the work */
/* of this routine. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we get here, we know we didn't have a match. Examine the */
/* highest scoring template to get available diagnostics */
/* about the mismatch. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
fixit = TRUE_;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &c_true, &cutoff, &pssthn, &m2code,
&score, error, temp_len, (ftnlen)32, command_len, error_len);
/* If we are in interactiive mode and we have a spelling error, we */
/* can attempt to fix it. Note this occurs only if the M2CODE */
/* is less than 100 mod 10000. */
while(m2code % 10000 < 100 && intrct && fixit) {
/* Construct a friendly message; display it; and */
/* get the user's response as to whether or not the */
/* command should be modified. */
s_copy(tryit, error, (ftnlen)600, error_len);
prefix_("Hmmmm.,,,", &c__1, tryit, (ftnlen)9, (ftnlen)600);
suffix_("/cr/cr I can repair this if you like.", &c__0, tryit, (
ftnlen)37, (ftnlen)600);
s_wsle(&io___19);
e_wsle();
niceio_3__(tryit, &c__6, style, (ftnlen)600, (ftnlen)128);
s_wsle(&io___20);
e_wsle();
s_wsle(&io___21);
e_wsle();
s_wsle(&io___22);
e_wsle();
s_wsle(&io___23);
e_wsle();
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) == 1) {
/* Writing concatenation */
i__2[0] = 17, a__1[0] = "Should I change \"";
i__2[1] = e - (b - 1), a__1[1] = command + (b - 1);
i__2[2] = 6, a__1[2] = "\" to \"";
i__2[3] = rtrim_(kwords + 192, (ftnlen)32), a__1[3] = kwords +
192;
i__2[4] = 3, a__1[4] = "\" ?";
s_cat(questn, a__1, i__2, &c__5, (ftnlen)80);
cnfirm_1__(questn, &fixit, rtrim_(questn, (ftnlen)80));
} else {
cnfirm_1__("Should I fix it?", &fixit, (ftnlen)16);
}
/* If the user has elected to have us fix the command */
/* we have a few things to do... */
if (fixit) {
/* Look up the suggested fixes. If there is more than */
/* one possibility, see which one the user thinks is */
/* best. Otherwise, no more questions for now. */
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) > 1) {
i__1 = cardc_(kwords, (ftnlen)32) - 4;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___27);
e_wsle();
}
i__1 = cardc_(kwords, (ftnlen)32);
getopt_1__("Which word did you mean?", &i__1, keynam, &c__6,
kwords + 192, &c__32, kwords + 192, pick, (ftnlen)24,
(ftnlen)6, (ftnlen)32, (ftnlen)32, (ftnlen)32);
} else {
s_copy(pick, kwords + 192, (ftnlen)32, (ftnlen)32);
}
/* Make the requested repairs on the command, and */
/* redisplay the command. */
repsub_(command, &b, &e, pick, command, command_len, (ftnlen)32,
command_len);
cmprss_(" ", &c__1, command, command, (ftnlen)1, command_len,
command_len);
s_wsle(&io___29);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___30);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
niceio_3__(command, &c__6, style, command_len, (ftnlen)128);
s_wsle(&io___31);
e_wsle();
/* Look through the templates again until we get a match or we */
/* run out of templates to try. Note however, that this time */
/* we will start in a different spot. We already have a best */
/* matching template. We'll start our search for a match */
/* there and simulate a circular list of templates so that */
/* we can examine all of them if necessary. */
s_copy(error, " ", error_len, (ftnlen)1);
s_copy(error + error_len, " ", error_len, (ftnlen)1);
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
j = *btemp - 1;
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the index of the next template to examine. */
++j;
while(j > *ntemps) {
j -= *ntemps;
}
/* Set the template, score for this template, spot to */
/* begin examining it and the M2CODE so far. */
s_copy(temp, temps + (j - 1) * temps_len, temp_len, temps_len)
;
sbeg = 1;
score = 0;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &
pssthn, &m2code, &score, error, temp_len, (ftnlen)32,
command_len, error_len);
/* If we get back a zero M2CODE we've got a match */
/* This routine's work is done. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
/* Hmmph. No match. See if we've got a better */
/* matching score so far and then go on to the next */
/* template if any are left. */
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we made it to this point the command doesn't properly */
/* match any of the templates. Get the best match and */
/* determine the diagnostics for this template. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len,
temps_len);
sbeg = 1;
m2code = 0;
score = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
}
}
/* If you get to this point. We didn't have a match set up */
/* the second level of mismatch diagnostics using the best */
/* matching template. (BTEMP already points to it.) */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
cmprss_(" ", &c__1, temp, temp, (ftnlen)1, temp_len, temp_len);
prepsn_(temp, temp_len);
prepsn_(error + error_len, error_len);
prefix_("/cr/cr(-3:-3) ", &c__1, error + error_len, (ftnlen)14, error_len)
;
prefix_(temp, &c__1, error + error_len, temp_len, error_len);
prefix_("/cr/cr(3:3) ", &c__1, error + error_len, (ftnlen)12, error_len);
prefix_("a command with the following syntax:", &c__3, error + error_len,
(ftnlen)36, error_len);
prefix_("I Believe you were trying to enter", &c__1, error + error_len, (
ftnlen)34, error_len);
prefix_("META/2:", &c__1, error + error_len, (ftnlen)7, error_len);
return 0;
/* The following entry point allows user's to adjust the margins */
/* of the META/2 error messages. */
L_m2marg:
s_copy(margns, temp, (ftnlen)128, temp_len);
return 0;
} /* meta_2__ */
/* Subroutine */ int cebchvxx_(real *thresh, char *path)
{
/* Format strings */
static char fmt_8000[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, INFO"
" = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
".5)";
static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
"r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
" / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
;
static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
"error\002)";
static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
"ber\002)";
static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
"n number\002)";
static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
"e\002)";
static char fmt_9999[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, RHS "
"= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
",\002 test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(\002 C\002,a2,\002SVXX: \002,i6,\002 out of"
" \002,i6,\002 tests failed to pass the threshold\002)";
static char fmt_9997[] = "(\002 C\002,a2,\002SVXX passed the tests of er"
"ror bounds\002)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4, r__5;
complex q__1, q__2, q__3;
/* Local variables */
real errbnd_c__[18], errbnd_n__[18];
complex a[36] /* was [6][6] */, b[36] /* was [6][6] */;
real c__[6];
integer i__, j, k;
real m;
integer n;
real r__[6], s[6];
complex x[36] /* was [6][6] */;
real cwise_bnd__;
char c2[2];
real nwise_bnd__, cwise_err__, nwise_err__, errthresh;
complex ab[66] /* was [11][6] */, af[36] /* was [6][6] */;
integer kl, ku;
real condthresh;
complex afb[96] /* was [16][6] */;
integer lda;
real eps, cwise_rcond__, nwise_rcond__;
integer n_aux_tests__, ldab;
real diff[36] /* was [6][6] */;
char fact[1];
real berr[6];
integer info, ipiv[6], nrhs;
real rinv[6];
char uplo[1];
complex work[90];
real sumr;
integer ldafb;
real ccond;
integer nfail;
char cguar[3];
real ncond;
char equed[1];
real rcond;
complex acopy[36] /* was [6][6] */;
char nguar[3], trans[1];
real rnorm, normt, sumri, rwork[18];
logical printed_guide__;
complex abcopy[66] /* was [11][6] */;
real params[2], orcond, rinorm, tstrat[6], rpvgrw;
complex invhilb[36] /* was [6][6] */;
real normdif;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
/* .. Scalar Arguments .. */
/* Purpose */
/* ====== */
/* CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then */
/* compare the error bounds returned by CGESVXX to see if the returned */
/* answer indeed falls within those bounds. */
/* Eight test ratios will be computed. The tests will pass if they are .LT. */
/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
/* If that value is .LE. to the component wise reciprocal condition number, */
/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
/* Test ratios: */
/* Let Xc be X_computed and Xt be X_truth. */
/* The norm used is the infinity norm. */
/* Let A be the guaranteed case and B be the unguaranteed case. */
/* 1. Normwise guaranteed forward error bound. */
/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
/* If these conditions are met, the test ratio is set to be */
/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
/* B: For this case, CGESVXX should just return 1. If it is less than */
/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
/* 2. Componentwise guaranteed forward error bound. */
/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
/* If these conditions are met, the test ratio is set to be */
/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
/* B: Same as normwise test ratio. */
/* 3. Backwards error. */
/* A: The test ratio is set to BERR/EPS. */
/* B: Same test ratio. */
/* 4. Reciprocal condition number. */
/* A: A condition number is computed with Xt and compared with the one */
/* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX */
/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
/* B: Test ratio is set to 1 / (EPS * RCONDc). */
/* 5. Reciprocal normwise condition number. */
/* A: The test ratio is set to */
/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
/* 6. Reciprocal componentwise condition number. */
/* A: Test ratio is set to */
/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
/* .. Parameters .. */
/* NMAX is determined by the largest number in the inverse of the hilbert */
/* matrix. Precision is exhausted when the largest entry in it is greater */
/* than 2 to the power of the number of bits in the fraction of the data */
/* type used plus one, which is 24 for single precision. */
/* NMAX should be 6 for single and 11 for double. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. Parameters .. */
/* Create the loop to test out the Hilbert matrices */
*(unsigned char *)fact = 'E';
*(unsigned char *)uplo = 'U';
*(unsigned char *)trans = 'N';
*(unsigned char *)equed = 'N';
eps = slamch_("Epsilon");
nfail = 0;
n_aux_tests__ = 0;
lda = 6;
ldab = 11;
ldafb = 16;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Main loop to test the different Hilbert Matrices. */
printed_guide__ = FALSE_;
for (n = 1; n <= 6; ++n) {
params[0] = -1.f;
params[1] = -1.f;
kl = n - 1;
ku = n - 1;
nrhs = n;
/* Computing MAX */
r__1 = sqrt((real) n);
m = dmax(r__1,10.f);
/* Generate the Hilbert matrix, its inverse, and the */
/* right hand side, all scaled by the LCM(1,..,2N-1). */
clahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info, path);
/* Copy A into ACOPY. */
clacpy_("ALL", &n, &n, a, &c__6, acopy, &c__6);
/* Store A in band format for GB tests */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__2 = kl + ku + 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 11 - 12;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
}
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = j - ku;
/* Computing MIN */
i__5 = n, i__6 = j + kl;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = ku + 1 + i__ - j + j * 11 - 12;
i__3 = i__ + j * 6 - 7;
ab[i__2].r = a[i__3].r, ab[i__2].i = a[i__3].i;
}
}
/* Copy AB into ABCOPY. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__4 = kl + ku + 1;
for (i__ = 1; i__ <= i__4; ++i__) {
i__2 = i__ + j * 11 - 12;
abcopy[i__2].r = 0.f, abcopy[i__2].i = 0.f;
}
}
i__1 = kl + ku + 1;
dlacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
/* Call C**SVXX with default PARAMS and N_ERR_BND = 3. */
if (lsamen_(&c__2, c2, "SY")) {
csysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
info);
} else if (lsamen_(&c__2, c2, "PO")) {
cposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &info);
} else if (lsamen_(&c__2, c2, "HE")) {
chesvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
info);
} else if (lsamen_(&c__2, c2, "GB")) {
cgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
params, work, rwork, &info);
} else {
cgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
&c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
rwork, &info);
}
++n_aux_tests__;
if (orcond < eps) {
/* Either factorization failed or the matrix is flagged, and 1 <= */
/* INFO <= N+1. We don't decide based on rcond anymore. */
/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
/* NFAIL = NFAIL + 1 */
/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
/* END IF */
} else {
/* Either everything succeeded (INFO == 0) or some solution failed */
/* to converge (INFO > N+1). */
if (info > 0 && info <= n + 1) {
++nfail;
s_wsfe(&io___42);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(real));
e_wsfe();
}
}
/* Calculating the difference between C**SVXX's X and the true X. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
i__3 = i__ + j * 6 - 7;
i__5 = i__ + j * 6 - 7;
q__1.r = x[i__3].r - invhilb[i__5].r, q__1.i = x[i__3].i -
invhilb[i__5].i;
diff[i__2] = q__1.r;
}
}
/* Calculating the RCOND */
rnorm = 0.f;
rinorm = 0.f;
if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
c2, "SY") || lsamen_(&c__2, c2, "HE")) {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumr = 0.f;
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
sumr += s[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
s[j - 1];
i__2 = i__ + j * 6 - 7;
sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
(s[j - 1] * s[i__ - 1]);
}
rnorm = dmax(rnorm,sumr);
rinorm = dmax(rinorm,sumri);
}
} else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
c__2, c2, "GB")) {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumr = 0.f;
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
sumr += r__[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
c__[j - 1];
i__2 = i__ + j * 6 - 7;
sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
(r__[j - 1] * c__[i__ - 1]);
}
rnorm = dmax(rnorm,sumr);
rinorm = dmax(rinorm,sumri);
}
}
rnorm /= (r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2));
rcond = 1.f / (rnorm * rinorm);
/* Calculating the R for normwise rcond. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
rinv[i__ - 1] = 0.f;
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
i__2 = i__ + j * 6 - 7;
rinv[i__ - 1] += (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * 6 - 7]), dabs(r__2));
}
}
/* Calculating the Normwise rcond. */
rinorm = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
i__3 = j - 1;
q__2.r = rinv[i__3] * invhilb[i__2].r, q__2.i = rinv[i__3] *
invhilb[i__2].i;
q__1.r = q__2.r, q__1.i = q__2.i;
sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
dabs(r__2));
}
rinorm = dmax(rinorm,sumri);
}
/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
ncond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2)))
/ rinorm;
condthresh = m * eps;
errthresh = m * eps;
i__1 = nrhs;
for (k = 1; k <= i__1; ++k) {
normt = 0.f;
normdif = 0.f;
cwise_err__ = 0.f;
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* Computing MAX */
i__2 = i__ + k * 6 - 7;
r__3 = (r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
invhilb[i__ + k * 6 - 7]), dabs(r__2));
normt = dmax(r__3,normt);
i__2 = i__ + k * 6 - 7;
i__3 = i__ + k * 6 - 7;
q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i -
invhilb[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
dabs(r__2));
normdif = dmax(r__3,normdif);
i__2 = i__ + k * 6 - 7;
if (invhilb[i__2].r != 0.f || invhilb[i__2].i != 0.f) {
i__2 = i__ + k * 6 - 7;
i__3 = i__ + k * 6 - 7;
q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i
- invhilb[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__5 = i__ + k * 6 - 7;
r__5 = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2))) / ((r__3 = invhilb[i__5].r,
dabs(r__3)) + (r__4 = r_imag(&invhilb[i__ + k * 6
- 7]), dabs(r__4)));
cwise_err__ = dmax(r__5,cwise_err__);
} else /* if(complicated condition) */ {
i__2 = i__ + k * 6 - 7;
if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
cwise_err__ = slamch_("OVERFLOW");
}
}
}
if (normt != 0.f) {
nwise_err__ = normdif / normt;
} else if (normdif != 0.f) {
nwise_err__ = slamch_("OVERFLOW");
} else {
nwise_err__ = 0.f;
}
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
rinv[i__ - 1] = 0.f;
}
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 6 - 7;
i__5 = j + k * 6 - 7;
q__2.r = a[i__3].r * invhilb[i__5].r - a[i__3].i *
invhilb[i__5].i, q__2.i = a[i__3].r * invhilb[
i__5].i + a[i__3].i * invhilb[i__5].r;
q__1.r = q__2.r, q__1.i = q__2.i;
rinv[i__ - 1] += (r__1 = q__1.r, dabs(r__1)) + (r__2 =
r_imag(&q__1), dabs(r__2));
}
}
rinorm = 0.f;
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
sumri = 0.f;
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 6 - 7;
i__5 = j - 1;
q__3.r = rinv[i__5] * invhilb[i__3].r, q__3.i = rinv[i__5]
* invhilb[i__3].i;
c_div(&q__2, &q__3, &invhilb[i__ + k * 6 - 7]);
q__1.r = q__2.r, q__1.i = q__2.i;
sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
}
rinorm = dmax(rinorm,sumri);
}
/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
ccond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(
r__2))) / rinorm;
/* Forward error bound tests */
nwise_bnd__ = errbnd_n__[k + nrhs - 1];
cwise_bnd__ = errbnd_c__[k + nrhs - 1];
nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
/* $ condthresh, ncond.ge.condthresh */
/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
if (ncond >= condthresh) {
s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
if (nwise_bnd__ > errthresh) {
tstrat[0] = 1 / (eps * 2.f);
} else {
if (nwise_bnd__ != 0.f) {
tstrat[0] = nwise_err__ / nwise_bnd__;
} else if (nwise_err__ != 0.f) {
tstrat[0] = 1 / (eps * 16.f);
} else {
tstrat[0] = 0.f;
}
if (tstrat[0] > 1.f) {
tstrat[0] = 1 / (eps * 4.f);
}
}
} else {
s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
if (nwise_bnd__ < 1.f) {
tstrat[0] = 1 / (eps * 8.f);
} else {
tstrat[0] = 1.f;
}
}
/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
/* $ condthresh, ccond.ge.condthresh */
/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
if (ccond >= condthresh) {
s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
if (cwise_bnd__ > errthresh) {
tstrat[1] = 1 / (eps * 2.f);
} else {
if (cwise_bnd__ != 0.f) {
tstrat[1] = cwise_err__ / cwise_bnd__;
} else if (cwise_err__ != 0.f) {
tstrat[1] = 1 / (eps * 16.f);
} else {
tstrat[1] = 0.f;
}
if (tstrat[1] > 1.f) {
tstrat[1] = 1 / (eps * 4.f);
}
}
} else {
s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
if (cwise_bnd__ < 1.f) {
tstrat[1] = 1 / (eps * 8.f);
} else {
tstrat[1] = 1.f;
}
}
/* Backwards error test */
tstrat[2] = berr[k - 1] / eps;
/* Condition number tests */
tstrat[3] = rcond / orcond;
if (rcond >= condthresh && tstrat[3] < 1.f) {
tstrat[3] = 1.f / tstrat[3];
}
tstrat[4] = ncond / nwise_rcond__;
if (ncond >= condthresh && tstrat[4] < 1.f) {
tstrat[4] = 1.f / tstrat[4];
}
tstrat[5] = ccond / nwise_rcond__;
if (ccond >= condthresh && tstrat[5] < 1.f) {
tstrat[5] = 1.f / tstrat[5];
}
for (i__ = 1; i__ <= 6; ++i__) {
if (tstrat[i__ - 1] > *thresh) {
if (! printed_guide__) {
s_wsle(&io___66);
e_wsle();
s_wsfe(&io___67);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___68);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___69);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___70);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___71);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___72);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___73);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___74);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
s_wsle(&io___75);
e_wsle();
printed_guide__ = TRUE_;
}
s_wsfe(&io___76);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, nguar, (ftnlen)3);
do_fio(&c__1, cguar, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
}
}
/* $$$ WRITE(*,*) */
/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
/* $$$ WRITE(*,*) */
/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
/* $$$ print *, 'Info: ', info */
/* $$$ WRITE(*,*) */
/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
}
s_wsle(&io___77);
e_wsle();
if (nfail > 0) {
s_wsfe(&io___78);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
i__1 = n * 6 + n_aux_tests__;
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfe();
} else {
s_wsfe(&io___79);
do_fio(&c__1, c2, (ftnlen)2);
e_wsfe();
}
/* Test ratios. */
return 0;
} /* cebchvxx_ */
/* Subroutine */ int cerrqr_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
complex q__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
complex a[4] /* was [2][2] */, b[2];
integer i__, j;
complex w[2], x[2], af[4] /* was [2][2] */;
integer info;
extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *), cung2r_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *), cunm2r_(char *, char *, integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, complex
*, integer *), alaesm_(char *, logical *, integer
*), cgeqrf_(integer *, integer *, complex *, integer *,
complex *, complex *, integer *, integer *), cgeqrs_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *, integer *), chkxer_(char *,
integer *, integer *, logical *, logical *), cungqr_(
integer *, integer *, integer *, complex *, integer *, complex *,
complex *, integer *, integer *), cunmqr_(char *, char *, integer
*, integer *, integer *, complex *, integer *, complex *, complex
*, integer *, complex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRQR tests the error exits for the COMPLEX routines */
/* that use the QR decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
i__1 = i__ + (j << 1) - 3;
r__1 = 1.f / (real) (i__ + j);
r__2 = -1.f / (real) (i__ + j);
q__1.r = r__1, q__1.i = r__2;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = i__ + (j << 1) - 3;
r__1 = 1.f / (real) (i__ + j);
r__2 = -1.f / (real) (i__ + j);
q__1.r = r__1, q__1.i = r__2;
af[i__1].r = q__1.r, af[i__1].i = q__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0.f, b[i__1].i = 0.f;
i__1 = j - 1;
w[i__1].r = 0.f, w[i__1].i = 0.f;
i__1 = j - 1;
x[i__1].r = 0.f, x[i__1].i = 0.f;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for QR factorization */
/* CGEQRF */
s_copy(srnamc_1.srnamt, "CGEQRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGEQR2 */
s_copy(srnamc_1.srnamt, "CGEQR2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGEQRS */
s_copy(srnamc_1.srnamt, "CGEQRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CUNGQR */
s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cungqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cungqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cungqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cungqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cungqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cungqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cungqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CUNG2R */
s_copy(srnamc_1.srnamt, "CUNG2R", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cung2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cung2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cung2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cung2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cung2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cung2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CUNMQR */
s_copy(srnamc_1.srnamt, "CUNMQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cunmqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cunmqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cunmqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cunmqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunmqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunmqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunmqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cunmqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cunmqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cunmqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CUNM2R */
s_copy(srnamc_1.srnamt, "CUNM2R", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cunm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cunm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cunm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cunm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cunm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cunm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRQR */
} /* cerrqr_ */
/* Subroutine */ int derrbd_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits\002,\002 (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts 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] */, d__[4], e[4];
integer i__, j;
doublereal q[16] /* was [4][4] */, u[16] /* was [4][4] */, v[16] /*
was [4][4] */, w[4];
char c2[2];
integer iq[16] /* was [4][4] */, iw[4], nt;
doublereal tp[4], tq[4];
integer info;
extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dbdsdc_(char *, char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dgebrd_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dorgbr_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), chkxer_(char *, integer *, integer *,
logical *, logical *), dormbr_(char *, char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___19 = { 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 .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRBD tests the error exits for DGEBRD, DORGBR, DORMBR, DBDSQR and */
/* DBDSDC. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
/* L20: */
}
infoc_1.ok = TRUE_;
nt = 0;
/* Test error exits of the SVD routines. */
if (lsamen_(&c__2, c2, "BD")) {
/* DGEBRD */
s_copy(srnamc_1.srnamt, "DGEBRD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 4;
/* DGEBD2 */
s_copy(srnamc_1.srnamt, "DGEBD2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgebd2_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &info);
chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgebd2_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &info);
chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgebd2_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &info);
chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 3;
/* DORGBR */
s_copy(srnamc_1.srnamt, "DORGBR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dorgbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorgbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorgbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dorgbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dorgbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dorgbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
/* DORMBR */
s_copy(srnamc_1.srnamt, "DORMBR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dormbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dormbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dormbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dormbr_("Q", "L", "T", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormbr_("Q", "L", "T", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dormbr_("Q", "L", "T", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormbr_("Q", "L", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormbr_("Q", "R", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormbr_("P", "L", "T", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormbr_("P", "R", "T", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dormbr_("Q", "L", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
&c__1, &info);
chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 13;
/* DBDSQR */
s_copy(srnamc_1.srnamt, "DBDSQR", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
a, &c__1, w, &info);
chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* DBDSDC */
s_copy(srnamc_1.srnamt, "DBDSDC", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dbdsdc_("/", "N", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
info);
chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dbdsdc_("U", "/", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
info);
chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dbdsdc_("U", "N", &c_n1, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
info);
chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dbdsdc_("U", "I", &c__2, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
info);
chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dbdsdc_("U", "I", &c__2, d__, e, u, &c__2, v, &c__1, q, iq, w, iw, &
info);
chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 5;
}
/* Print a summary line. */
if (infoc_1.ok) {
io___18.ciunit = infoc_1.nout;
s_wsfe(&io___18);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of DERRBD */
} /* derrbd_ */
/* $Procedure WRLINE ( Write Output Line to a Device ) */
/* Subroutine */ int wrline_0_(int n__, char *device, char *line, ftnlen
device_len, ftnlen line_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_inqu(inlist *),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen);
char error[240];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical opened;
extern /* Subroutine */ int fndlun_(integer *);
char tmpnam[128];
integer iostat;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
logical exists;
char errstr[11];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Write a character string to an output device. */
/* $ 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 */
/* TEXT */
/* FILES */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I A string specifying an output device. */
/* LINE I A line of text to be output. */
/* FILEN P Maximum length of a file name. */
/* $ Detailed_Input */
/* LINE is a line of text to be written to the output */
/* device specified by DEVICE. */
/* DEVICE is the output device to which the line of text */
/* will be written. */
/* Possible values and meanings of DEVICE are: */
/* a device name This may be the name of a */
/* file, or any other name that */
/* is valid in a FORTRAN OPEN */
/* statement. For example, on a */
/* VAX, a logical name may be */
/* used. */
/* The device name must not */
/* be any of the reserved strings */
/* below. */
/* 'SCREEN' The output will go to the */
/* terminal screen. */
/* 'NULL' The data will not be output. */
/* 'SCREEN' and 'NULL' can be written in mixed */
/* case. For example, the following call will work: */
/* CALL WRLINE ( 'screEn', LINE ) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* This routine is a special case as far as error handling */
/* is concerned because it is called to output error */
/* messages resulting from errors detected by other routines. */
/* In such a case, calling SIGERR would constitute recursion. */
/* Therefore, this routine prints error messages rather */
/* than signalling errors via SIGERR and setting the long */
/* error message via SETMSG. */
/* The following exceptional cases are treated as errors: */
/* 1) SPICE(NOFREELOGICALUNIT) -- No logical unit number */
/* is available to refer to the device. */
/* 2) SPICE(FILEOPENFAILED) -- General file open error. */
/* 3) SPICE(FILEWRITEFAILED) -- General file write error. */
/* 4) SPICE(INQUIREFAILED) -- INQUIRE statement failed. */
/* 5) Leading blanks in (non-blank) file names are not */
/* significant. The file names */
/* 'MYFILE.DAT' */
/* ' MYFILE.DAT' */
/* are considered to name the same file. */
/* 6) If different names that indicate the same file are supplied */
/* to this routine on different calls, all output associated */
/* with these calls WILL be written to the file. For example, */
/* on a system where logical filenames are supported, if */
/* ALIAS is a logical name pointing to MYFILE, then the calls */
/* CALL WRLINE ( 'MYFILE', 'This is the first line' ) */
/* CALL WRLINE ( 'ALIAS', 'This is the second line' ) */
/* will place the lines of text */
/* 'This is the first line' */
/* 'This is the second line' */
/* in MYFILE. See $Restrictions for more information on use */
/* of logical names on VAX systems. */
/* $ Files */
/* 1) If DEVICE specifies a device other than 'SCREEN' or 'NULL', */
/* that device is opened (if it's not already open) as a NEW, */
/* SEQUENTIAL, FORMATTED file. The logical unit used is */
/* determined at run time. */
/* $ Particulars */
/* If the output device is a file that is not open, the file will */
/* be opened (if possible) as a NEW, sequential, formatted file, */
/* and the line of text will be written to the file. If the file */
/* is already opened as a sequential, formatted file, the line of */
/* text will be written to the file. */
/* Use the entry point CLLINE to close files opened by WRLINE. */
/* $ Examples */
/* 1) Write a message to the screen: */
/* CALL WRLINE ( 'SCREEN', 'Here''s a message.' ) */
/* The text */
/* Here's a message. */
/* will be written to the screen. */
/* 2) Write out all of the elements of a character string array */
/* to a file. */
/* CHARACTER*(80) STRING ( ASIZE ) */
/* . */
/* . */
/* . */
/* DO I = 1, ASIZE */
/* CALL WRLINE ( FILE, STRING(I) ) */
/* END DO */
/* 3) Set DEVICE to NULL to suppress output: */
/* C */
/* C Ask the user whether verbose program output is */
/* C desired. Set the output device accordingly. */
/* C */
/* WRITE (*,*) 'Do you want to see test results ' // */
/* . 'on the screen?' */
/* READ (*,FMT='(A)') VERBOS */
/* CALL LJUST ( VERBOS, VERBOS ) */
/* CALL UCASE ( VERBOS, VERBOS ) */
/* IF ( VERBOS(1:1) .EQ. 'Y' ) THEN */
/* DEVICE = 'SCREEN' */
/* ELSE */
/* DEVICE = 'NULL' */
/* ENDIF */
/* . */
/* . */
/* . */
/* C */
/* C Output test results. */
/* C */
/* CALL WRLINE ( DEVICE, STRING ) */
/* . */
/* . */
/* . */
/* $ Restrictions */
/* 1) File names must not exceed FILEN characters. */
/* 2) On VAX systems, caution should be exercised when using */
/* multiple logical names to point to the same file. Logical */
/* name translation supporting execution of the Fortran */
/* INQUIRE statement does not appear to work reliably in all */
/* cases, which may lead this routine to believe that different */
/* logical names indicate different files. The specific problem */
/* that has been observed is that logical names that include */
/* disk specifications are not always recognized as pointing */
/* to the file they actually name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.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 4.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. The */
/* write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* This routine now can write to files that have been opened */
/* by other routines. */
/* The limit imposed by this routine on the number of files it */
/* can open has been removed. */
/* The output file is now opened as a normal text file on */
/* VAX systems. */
/* Improper treatment of the case where DEVICE is blank was */
/* remedied. */
/* Unneeded variable declarations and references were removed. */
/* Initialization of SAVED variables was added. */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Calls to UCASE and LJUST replace in-line code that performed */
/* these operations. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* write output line to a device */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* The write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.0, 25-MAR-1991 (NJB) */
/* 1) This routine now can write to files that have been opened */
/* by other routines. WRLINE uses an INQUIRE statement to */
/* determine whether the file indicated by DEVICE is open, */
/* and if it is, WRLINE does not attempt to open it. This */
/* allows use of WRLINE to feed error output into a log file */
/* opened by another routine. */
/* The header has been updated accordingly. */
/* This fix also fixes a bug wherein this routine would treat */
/* different character strings naming the same file as though */
/* they indicated different files. */
/* 2) The limit imposed by this routine on the number of files it */
/* can open has been removed. The file database used in */
/* previous versions of this routine is no longer used. */
/* 3) On VAX systems, this routine now opens the output file */
/* (when required to do so) as a normal text file. */
/* 4) Improper treatment of the case where DEVICE is blank was */
/* remedied. Any value of DEVICE that is not equal to */
/* 'SCREEN' or 'NULL' after being left-justified and */
/* converted to upper case is considered to be a file name. */
/* 5) Unneeded variable declarations and references were removed. */
/* The arrays called STATUS and FILES are not needed. */
/* 6) All instances if "PRINT *" have been replaced by */
/* "WRITE (*,*)" because Language Systems Fortran on the */
/* Macintosh interprets "PRINT *" in a non-standard manner. */
/* 7) Use of the EXIST specifier was added to the INQUIRE */
/* statement used to determine whether the file named by */
/* DEVICE is open. This is a work-around for a rather */
/* peculiar behavior of at least one version of Sun Fortran: */
/* files that don't exist may be considered to be open, as */
/* indicated by the OPENED specifier of the INQUIRE statement. */
/* 8) One other thing: now that LJUST and UCASE are error-free, */
/* WRLINE uses them; this simplifies the code. */
/* - Beta Version 1.2.0, 27-FEB-1989 (NJB) */
/* Call to GETLUN replaced by call to FNDLUN, which is error-free. */
/* Call to IOERR replaced with in-line code to construct long */
/* error message indicating file open failure. Arrangement of */
/* declarations changed. Keywords added. FILEN declaration */
/* moved to "declarations" section. Parameters section added. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Upper bound of written substring changed to prevent use of */
/* invalid substring bound. Specifically, LASTNB ( LINE ) was */
/* replaced by MAX ( 1, LASTNB (LINE) ). This upper bound */
/* now used in the PRINT statement as well. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Executable Code: */
switch(n__) {
case 1: goto L_clline;
}
ljust_(device, tmpnam, device_len, (ftnlen)128);
ucase_(tmpnam, tmpnam, (ftnlen)128, (ftnlen)128);
/* TMPNAM is now left justified and is in upper case. */
if (s_cmp(tmpnam, "NULL", (ftnlen)128, (ftnlen)4) == 0) {
return 0;
} else if (s_cmp(tmpnam, "SCREEN", (ftnlen)128, (ftnlen)6) == 0) {
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
return 0;
}
/* Find out whether we'll need to open the file. */
/* We use the EXIST inquiry specifier because files that don't exist */
/* may be (possibly due to a Sun compiler bug) deemed to be OPEN by */
/* Sun Fortran. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = &exists;
ioin__1.inopen = &opened;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___6);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___7);
do_lio(&c__9, &c__1, "WRLINE: File = ", (ftnlen)15);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
if (! (opened && exists)) {
/* We will need a free logical unit. There is always the chance */
/* that no units are available. */
fndlun_(&unit);
if (unit < 1) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, "SPICE(NOFREELOGICALUNIT)", (ftnlen)24);
e_wsle();
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, "WRLINE: Maximum number of logical units th"
"at can be allocated by SPICELIB has already been reached",
(ftnlen)98);
e_wsle();
return 0;
}
/* Okay, we have a unit. Open the file, and hope nothing */
/* goes awry. (On the VAX, the qualifier */
/* CARRIAGECONTROL = 'LIST' */
/* may be inserted into the OPEN statement.) */
i__1 = ltrim_(device, device_len) - 1;
o__1.oerr = 1;
o__1.ounit = unit;
o__1.ofnmlen = device_len - i__1;
o__1.ofnm = device + i__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, "SPICE(FILEOPENFAILED)", (ftnlen)21);
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_copy(error, "WRLINE: An error occurred while attempting to open"
, (ftnlen)240, (ftnlen)50);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)
32, (ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___15);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
/* Whew! We're ready to write to this file. */
}
/* At this point, either we opened the file, or it was already */
/* opened by somebody else. */
/* This is the easy part. Write the next line to the file. */
ci__1.cierr = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
/* Well, what happened? Any non-zero value for IOSTAT indicates */
/* an error. */
if (iostat != 0) {
s_copy(error, "WRLINE: An error occurred while attempting to WRITE t"
"o ", (ftnlen)240, (ftnlen)55);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)32,
(ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___16);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
return 0;
/* $Procedure CLLINE ( Close a device ) */
L_clline:
/* $ Abstract */
/* Close a device. */
/* $ 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 */
/* TEXT, FILES, ERROR */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device to be closed. */
/* $ Detailed_Input */
/* DEVICE is the name of a device which is currently */
/* opened for reading or writing. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This routine is called by SPICELIB error handling routines, so */
/* it cannot use the normal SPICELIB error signalling mechanism. */
/* Instead, it writes error messages to the screen if necessary. */
/* 1) If the device indicated by DEVICE was not opened by WRLINE, */
/* this routine closes it anyway. */
/* 2) If the INQUIRE performed by this routine fails, an error */
/* diagnosis is printed to the screen. */
/* $ Files */
/* This routin */
/* $ Particulars */
/* CLLINE closes a device that is currently open. */
/* $ Examples */
/* 1) Write two lines to the file, SPUD.DAT (VAX file name */
/* syntax), and then close the file. */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 1 ' ) */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 2 ' ) */
/* CALL CLLINE ( 'SPUD.DAT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.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 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Also, this routine now closes the device named by DEVICE */
/* whether or not the device was opened by WRLINE. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All instances if "PRINT *" have been replaced by "WRITE (*,*)" */
/* because Language Systems Fortran on the Macintosh interprets */
/* "PRINT *" in a non-standard manner. */
/* This routine no longer has to maintain the file database, since */
/* WRLINE does not use it any more. */
/* Also, this routine now closes the device named by DEVICE, */
/* whether or not the device was opened by WRLINE. */
/* - Beta Version 1.0.1, 08-NOV-1988 (NJB) */
/* Keywords added. */
/* -& */
/* Find the unit connected to DEVICE. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___17);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, "CLLINE: File = ", (ftnlen)16);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* wrline_ */
/* Subroutine */ int zdrvrf3_(integer *nout, integer *nn, integer *nval,
doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
arf, doublecomplex *b1, doublecomplex *b2, doublereal *
d_work_zlange__, doublecomplex *z_work_zgeqrf__, doublecomplex *tau)
{
/* 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 sides[1*2] = "L" "R";
static char transs[1*2] = "N" "C";
static char diags[1*2] = "N" "U";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
"ing ZTFSM ***\002)";
static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
"'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
"\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
"\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
"=\002,g12.5)";
static char fmt_9996[] = "(1x,\002All tests for \002,a5,\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)";
/* System generated locals */
integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
i__2, i__3, i__4, i__5, i__6, i__7;
doublecomplex z__1, z__2;
/* Local variables */
integer i__, j, m, n, na, iim, iin;
doublereal eps;
char diag[1], side[1];
integer info;
char uplo[1];
integer nrun, idiag;
doublecomplex alpha;
integer nfail, iseed[4], iside;
char cform[1];
integer iform;
char trans[1];
integer iuplo;
integer ialpha;
integer itrans;
doublereal result[1];
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9995, 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 */
/* ======= */
/* ZDRVRF3 tests the LAPACK RFP routines: */
/* ZTFSM */
/* 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). */
/* B1 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
/* B2 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
/* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* Z_WORK_ZGEQRF (workspace) COMPLEX*16 array, dimension (NMAX) */
/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
b2_dim1 = *lda;
b2_offset = 1 + b2_dim1;
b2 -= b2_offset;
b1_dim1 = *lda;
b1_offset = 1 + b1_dim1;
b1 -= b1_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--d_work_zlange__;
--z_work_zgeqrf__;
--tau;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nfail = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Precision");
i__1 = *nn;
for (iim = 1; iim <= i__1; ++iim) {
m = nval[iim];
i__2 = *nn;
for (iin = 1; iin <= i__2; ++iin) {
n = nval[iin];
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[
iside - 1];
for (itrans = 1; itrans <= 2; ++itrans) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itrans - 1];
for (idiag = 1; idiag <= 2; ++idiag) {
*(unsigned char *)diag = *(unsigned char *)&
diags[idiag - 1];
for (ialpha = 1; ialpha <= 3; ++ialpha) {
if (ialpha == 1) {
alpha.r = 0., alpha.i = 0.;
} else if (ialpha == 1) {
alpha.r = 1., alpha.i = 0.;
} else {
zlarnd_(&z__1, &c__4, iseed);
alpha.r = z__1.r, alpha.i = z__1.i;
}
/* All the parameters are set: */
/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
/* and ALPHA */
/* READY TO TEST! */
++nrun;
if (iside == 1) {
/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
/* -> A is M-by-M ( B is M-by-N ) */
na = m;
} else {
/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
/* -> A is N-by-N ( B is M-by-N ) */
na = n;
}
/* Generate A our NA--by--NA triangular */
/* matrix. */
/* Our test is based on forward error so we */
/* do want A to be well conditionned! To get */
/* a well-conditionned triangular matrix, we */
/* take the R factor of the QR/LQ factorization */
/* of a random matrix. */
i__3 = na;
for (j = 1; j <= i__3; ++j) {
i__4 = na;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * a_dim1;
zlarnd_(&z__1, &c__4, iseed);
a[i__5].r = z__1.r, a[i__5].i =
z__1.i;
}
}
if (iuplo == 1) {
/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
/* -> QR factorization. */
s_copy(srnamc_1.srnamt, "ZGEQRF", (
ftnlen)32, (ftnlen)6);
zgeqrf_(&na, &na, &a[a_offset], lda, &
tau[1], &z_work_zgeqrf__[1],
lda, &info);
} else {
/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
/* -> QL factorization. */
s_copy(srnamc_1.srnamt, "ZGELQF", (
ftnlen)32, (ftnlen)6);
zgelqf_(&na, &na, &a[a_offset], lda, &
tau[1], &z_work_zgeqrf__[1],
lda, &info);
}
/* After the QR factorization, the diagonal */
/* of A is made of real numbers, we multiply */
/* by a random complex number of absolute */
/* value 1.0E+00. */
i__3 = na;
for (j = 1; j <= i__3; ++j) {
i__4 = j + j * a_dim1;
i__5 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, iseed);
z__1.r = a[i__5].r * z__2.r - a[i__5]
.i * z__2.i, z__1.i = a[i__5]
.r * z__2.i + a[i__5].i *
z__2.r;
a[i__4].r = z__1.r, a[i__4].i =
z__1.i;
}
/* Store a copy of A in RFP format (in ARF). */
s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)
32, (ftnlen)6);
ztrttf_(cform, uplo, &na, &a[a_offset],
lda, &arf[1], &info);
/* Generate B1 our M--by--N right-hand side */
/* and store a copy in B2. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * b1_dim1;
zlarnd_(&z__1, &c__4, iseed);
b1[i__5].r = z__1.r, b1[i__5].i =
z__1.i;
i__5 = i__ + j * b2_dim1;
i__6 = i__ + j * b1_dim1;
b2[i__5].r = b1[i__6].r, b2[i__5]
.i = b1[i__6].i;
}
}
/* Solve op( A ) X = B or X op( A ) = B */
/* with ZTRSM */
s_copy(srnamc_1.srnamt, "ZTRSM", (ftnlen)
32, (ftnlen)5);
ztrsm_(side, uplo, trans, diag, &m, &n, &
alpha, &a[a_offset], lda, &b1[
b1_offset], lda);
/* Solve op( A ) X = B or X op( A ) = B */
/* with ZTFSM */
s_copy(srnamc_1.srnamt, "ZTFSM", (ftnlen)
32, (ftnlen)5);
ztfsm_(cform, side, uplo, trans, diag, &m,
&n, &alpha, &arf[1], &b2[
b2_offset], lda);
/* Check that the result agrees. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + j * b1_dim1;
i__6 = i__ + j * b2_dim1;
i__7 = i__ + j * b1_dim1;
z__1.r = b2[i__6].r - b1[i__7].r,
z__1.i = b2[i__6].i - b1[
i__7].i;
b1[i__5].r = z__1.r, b1[i__5].i =
z__1.i;
}
}
result[0] = zlange_("I", &m, &n, &b1[
b1_offset], lda, &d_work_zlange__[
1]);
/* Computing MAX */
i__3 = max(m,n);
result[0] = result[0] / sqrt(eps) / max(
i__3,1);
if (result[0] >= *thresh) {
if (nfail == 0) {
io___32.ciunit = *nout;
s_wsle(&io___32);
e_wsle();
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "ZTFSM", (ftnlen)5);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, side, (ftnlen)1);
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 *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* L170: */
}
/* Print a summary of the results. */
if (nfail == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "ZTFSM", (ftnlen)5);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, "ZTFSM", (ftnlen)5);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of ZDRVRF3 */
} /* zdrvrf3_ */
