/* Subroutine */ int cchkeq_(real *thresh, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
"ssed the threshold\002)";
static char fmt_9998[] = "(\002 CGEEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9997[] = "(\002 CGBEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9996[] = "(\002 CPOEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9995[] = "(\002 CPPEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9994[] = "(\002 CPBEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
real r__1, r__2, r__3;
complex q__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double pow_ri(real *, integer *);
integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
complex a[25] /* was [5][5] */;
real c__[5];
integer i__, j, m, n;
real r__[5];
complex ab[65] /* was [13][5] */, ap[15];
integer kl;
logical ok;
integer ku;
real eps, pow[11];
integer info;
char path[3];
real norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
integer *, real *, real *, real *, real *, real *, integer *),
cpbequ_(char *, integer *, integer *, complex *, integer *, real *
, real *, real *, integer *), cpoequ_(integer *, complex *
, integer *, real *, real *, real *, integer *), cppequ_(char *,
integer *, complex *, real *, real *, real *, integer *);
real reslts[5];
/* Fortran I/O blocks */
static cilist io___25 = { 0, 0, 0, 0, 0 };
static cilist io___26 = { 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, fmt_9996, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKEQ tests CGEEQU, CGBEQU, CPOEQU, CPPEQU and CPBEQU */
/* Arguments */
/* ========= */
/* THRESH (input) REAL */
/* Threshold for testing routines. Should be between 2 and 10. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
eps = slamch_("P");
for (i__ = 1; i__ <= 5; ++i__) {
reslts[i__ - 1] = 0.f;
/* L10: */
}
for (i__ = 1; i__ <= 11; ++i__) {
i__1 = i__ - 1;
pow[i__ - 1] = pow_ri(&c_b9, &i__1);
rpow[i__ - 1] = 1.f / pow[i__ - 1];
/* L20: */
}
/* Test CGEEQU */
for (n = 0; n <= 5; ++n) {
for (m = 0; m <= 5; ++m) {
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 5; ++i__) {
if (i__ <= m && j <= n) {
i__1 = i__ + j * 5 - 6;
i__2 = i__ + j;
r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
a[i__1].r = r__1, a[i__1].i = 0.f;
} else {
i__1 = i__ + j * 5 - 6;
a[i__1].r = 0.f, a[i__1].i = 0.f;
}
/* L30: */
}
/* L40: */
}
cgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 0) {
reslts[0] = 1.f;
} else {
if (n != 0 && m != 0) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (rcond - rpow[m - 1]) /
rpow[m - 1], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (ccond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (norm - pow[n + m]) /
pow[n + m], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__ + n]) / rpow[i__ + n], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* L50: */
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (c__[j - 1] - pow[n
- j]) / pow[n - j], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* L60: */
}
}
}
/* L70: */
}
/* L80: */
}
/* Test with zero rows and columns */
for (j = 1; j <= 5; ++j) {
i__1 = j * 5 - 2;
a[i__1].r = 0.f, a[i__1].i = 0.f;
/* L90: */
}
cgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 4) {
reslts[0] = 1.f;
}
for (j = 1; j <= 5; ++j) {
i__1 = j * 5 - 2;
a[i__1].r = 1.f, a[i__1].i = 0.f;
/* L100: */
}
for (i__ = 1; i__ <= 5; ++i__) {
i__1 = i__ + 14;
a[i__1].r = 0.f, a[i__1].i = 0.f;
/* L110: */
}
cgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 9) {
reslts[0] = 1.f;
}
reslts[0] /= eps;
/* Test CGBEQU */
for (n = 0; n <= 5; ++n) {
for (m = 0; m <= 5; ++m) {
/* Computing MAX */
i__2 = m - 1;
i__1 = max(i__2,0);
for (kl = 0; kl <= i__1; ++kl) {
/* Computing MAX */
i__3 = n - 1;
i__2 = max(i__3,0);
for (ku = 0; ku <= i__2; ++ku) {
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
i__3 = i__ + j * 13 - 14;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
/* L120: */
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
/* Computing MIN */
i__5 = m, i__6 = j + kl;
/* Computing MAX */
i__7 = 1, i__8 = j - ku;
if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
&& j <= n) {
i__5 = ku + 1 + i__ - j + j * 13 - 14;
i__6 = i__ + j;
r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__6);
ab[i__5].r = r__1, ab[i__5].i = 0.f;
}
/* L140: */
}
/* L150: */
}
cgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
ccond, &norm, &info);
if (info != 0) {
if (! (n + kl < m && info == n + kl + 1 || m + ku < n
&& info == (m << 1) + ku + 1)) {
reslts[1] = 1.f;
}
} else {
if (n != 0 && m != 0) {
rcmin = r__[0];
rcmax = r__[0];
i__3 = m;
for (i__ = 1; i__ <= i__3; ++i__) {
/* Computing MIN */
r__1 = rcmin, r__2 = r__[i__ - 1];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = r__[i__ - 1];
rcmax = dmax(r__1,r__2);
/* L160: */
}
ratio = rcmin / rcmax;
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (rcond - ratio) /
ratio, dabs(r__1));
reslts[1] = dmax(r__2,r__3);
rcmin = c__[0];
rcmax = c__[0];
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = c__[j - 1];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = c__[j - 1];
rcmax = dmax(r__1,r__2);
/* L170: */
}
ratio = rcmin / rcmax;
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (ccond - ratio) /
ratio, dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (norm - pow[n +
m]) / pow[n + m], dabs(r__1));
reslts[1] = dmax(r__2,r__3);
i__3 = m;
for (i__ = 1; i__ <= i__3; ++i__) {
rcmax = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
if (i__ <= j + kl && i__ >= j - ku) {
ratio = (r__1 = r__[i__ - 1] * pow[
i__ + j] * c__[j - 1], dabs(
r__1));
rcmax = dmax(rcmax,ratio);
}
/* L180: */
}
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* L190: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
rcmax = 0.f;
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
if (i__ <= j + kl && i__ >= j - ku) {
ratio = (r__1 = r__[i__ - 1] * pow[
i__ + j] * c__[j - 1], dabs(
r__1));
rcmax = dmax(rcmax,ratio);
}
/* L200: */
}
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* L210: */
}
}
}
/* L220: */
}
/* L230: */
}
/* L240: */
}
/* L250: */
}
reslts[1] /= eps;
/* Test CPOEQU */
for (n = 0; n <= 5; ++n) {
for (i__ = 1; i__ <= 5; ++i__) {
for (j = 1; j <= 5; ++j) {
if (i__ <= n && j == i__) {
i__1 = i__ + j * 5 - 6;
i__2 = i__ + j;
r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
a[i__1].r = r__1, a[i__1].i = 0.f;
} else {
i__1 = i__ + j * 5 - 6;
a[i__1].r = 0.f, a[i__1].i = 0.f;
}
/* L260: */
}
/* L270: */
}
cpoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[2] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
/* L280: */
}
}
}
/* L290: */
}
q__1.r = -1.f, q__1.i = -0.f;
a[18].r = q__1.r, a[18].i = q__1.i;
cpoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
if (info != 4) {
reslts[2] = 1.f;
}
reslts[2] /= eps;
/* Test CPPEQU */
for (n = 0; n <= 5; ++n) {
/* Upper triangular packed storage */
i__1 = n * (n + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ap[i__2].r = 0.f, ap[i__2].i = 0.f;
/* L300: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * (i__ + 1) / 2 - 1;
i__3 = i__ << 1;
ap[i__2].r = pow[i__3], ap[i__2].i = 0.f;
/* L310: */
}
cppequ_("U", &n, ap, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[3] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* L320: */
}
}
}
/* Lower triangular packed storage */
i__1 = n * (n + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ap[i__2].r = 0.f, ap[i__2].i = 0.f;
/* L330: */
}
j = 1;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = j - 1;
i__3 = i__ << 1;
ap[i__2].r = pow[i__3], ap[i__2].i = 0.f;
j += n - i__ + 1;
/* L340: */
}
cppequ_("L", &n, ap, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[3] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* L350: */
}
}
}
/* L360: */
}
i__ = 13;
i__1 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
cppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
if (info != 4) {
reslts[3] = 1.f;
}
reslts[3] /= eps;
/* Test CPBEQU */
for (n = 0; n <= 5; ++n) {
/* Computing MAX */
i__2 = n - 1;
i__1 = max(i__2,0);
for (kl = 0; kl <= i__1; ++kl) {
/* Test upper triangular storage */
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
i__2 = i__ + j * 13 - 14;
ab[i__2].r = 0.f, ab[i__2].i = 0.f;
/* L370: */
}
/* L380: */
}
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = kl + 1 + j * 13 - 14;
i__4 = j << 1;
ab[i__3].r = pow[i__4], ab[i__3].i = 0.f;
/* L390: */
}
cpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[4] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
pow[n * 2], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__]) / rpow[i__], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* L400: */
}
}
}
if (n != 0) {
/* Computing MAX */
i__3 = n - 1;
i__2 = kl + 1 + max(i__3,1) * 13 - 14;
q__1.r = -1.f, q__1.i = -0.f;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
cpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
/* Computing MAX */
i__2 = n - 1;
if (info != max(i__2,1)) {
reslts[4] = 1.f;
}
}
/* Test lower triangular storage */
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
i__2 = i__ + j * 13 - 14;
ab[i__2].r = 0.f, ab[i__2].i = 0.f;
/* L410: */
}
/* L420: */
}
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = j * 13 - 13;
i__4 = j << 1;
ab[i__3].r = pow[i__4], ab[i__3].i = 0.f;
/* L430: */
}
cpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[4] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
pow[n * 2], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__]) / rpow[i__], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* L440: */
}
}
}
if (n != 0) {
/* Computing MAX */
i__3 = n - 1;
i__2 = max(i__3,1) * 13 - 13;
q__1.r = -1.f, q__1.i = -0.f;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
cpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
/* Computing MAX */
i__2 = n - 1;
if (info != max(i__2,1)) {
reslts[4] = 1.f;
}
}
/* L450: */
}
/* L460: */
}
reslts[4] /= eps;
ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
&& reslts[3] <= *thresh && reslts[4] <= *thresh;
io___25.ciunit = *nout;
s_wsle(&io___25);
e_wsle();
if (ok) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else {
if (reslts[0] > *thresh) {
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[1] > *thresh) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[2] > *thresh) {
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[3] > *thresh) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[4] > *thresh) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
}
return 0;
/* End of CCHKEQ */
} /* cchkeq_ */
/* Subroutine */ int zerrac_(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;
/* 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 info, iter;
doublecomplex work[16];
doublereal rwork[4];
complex swork[16];
/* 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.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* May 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRPX tests the error exits for ZCPOSV. */
/* 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__) {
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.;
/* L20: */
}
infoc_1.ok = TRUE_;
s_copy(srnamc_1.srnamt, "ZCPOSV", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zcposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zcposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zcposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zcposv_("U", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zcposv_("U", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zcposv_("U", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, work, swork,
rwork, &iter, &info);
chkxer_("ZCPOSV", &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, "ZCPOSV", (ftnlen)6);
e_wsfe();
} else {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, "ZCPOSV", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of ZERRAC */
} /* zerrac_ */
/* Subroutine */ int serrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error ex\002,\002its ***\002)";
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, ifst, ilst;
static real work[4], a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[
16] /* was [4][4] */;
static integer i__, j, m;
static real s[4], scale;
static integer iwork[4];
static real wi[4];
static integer nt;
static real wr[4];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), strexc_(char *, integer *, real *, integer
*, real *, integer *, integer *, integer *, real *, integer *), strsna_(char *, char *, logical *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
integer *, integer *, real *, integer *, integer *, integer *), strsen_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, integer *, integer *, integer *, integer *
), strsyl_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *);
static logical sel[4];
static real sep[4];
/* Fortran I/O blocks */
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
#define b_ref(a_1,a_2) b[(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
June 30, 1999
Purpose
=======
SERREC tests the error exits for the routines for eigen- condition
estimation for REAL matrices:
STRSYL, STREXC, STRSNA and STRSEN.
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;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 0.f;
b_ref(i__, j) = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, i__) = 1.f;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test STRSYL */
s_copy(srnamc_1.srnamt, "STRSYL", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STREXC */
s_copy(srnamc_1.srnamt, "STREXC", (ftnlen)6, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
strexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
strexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STRSNA */
s_copy(srnamc_1.srnamt, "STRSNA", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test STRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "STRSEN", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__2, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__0, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__3, iwork, &c__2, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("E", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__0, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__4, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
/* Print a summary line. */
if (infoc_1.ok) {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___20.ciunit = infoc_1.nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of SERREC */
} /* serrec_ */
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
",\002, ratio= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
"2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
") = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
/* Local variables */
integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
ldab, ioff, mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
integer kdval[4];
doublereal rcond;
integer nimat;
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
doublereal rcondc;
char packit[1];
doublereal cndnum;
doublereal ainvnm;
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPB tests DPBTRF, -TRS, -RFS, and -CON. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
kdval[0] = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations. */
/* Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
/* makes it easier to skip redundant values for small values */
/* of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
*(unsigned char *)packit = 'Q';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L60;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L60;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with DLATB4 and generate a test */
/* matrix with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)
6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L60;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type */
/* 2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix */
/* to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the band */
/* matrix. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
ldab);
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)
6);
dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Check error code from DPBTRF. */
if (info != izero) {
alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
nout);
goto L50;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L50;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute */
/* residual. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
&ldab);
dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
&rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Only do other tests if this is the first blocksize. */
if (inb > 1) {
goto L50;
}
/* Form the inverse of A so we can get a good estimate */
/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)
6);
dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
&lda, &info);
/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
rwork[1]);
ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 2 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
&nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (
ftnlen)6);
dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
1], &lda, &info);
/* Check error code from DPBTRS. */
if (info != 0) {
alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (
ftnlen)6);
dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
1], &ldab, &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPBRFS. */
if (info != 0) {
alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
&lda, &x[1], &lda, &xact[1], &lda, &
rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += 5;
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)
6);
dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
rcond, &work[1], &iwork[1], &info);
/* Check error code from DPBCON. */
if (info != 0) {
alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L50:
;
}
L60:
;
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPB */
} /* dchkpb_ */
/* Subroutine */ int sckglm_(integer *nn, integer *mval, integer *pval,
integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
nmax, real *a, real *af, real *b, real *bf, real *x, real *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 SLATMS in SCKGLM 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;
/* 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 /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, real *, integer *, real *, integer *);
logical dotype[8];
extern /* Subroutine */ int sglmts_(integer *, integer *, integer *, real
*, real *, integer *, real *, real *, integer *, real *, real *,
real *, real *, real *, integer *, real *, real *);
logical 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 */
/* ======= */
/* SCKGLM tests SGGGLM - 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. */
/* 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. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix 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) 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) REAL array, dimension (NMAX*NMAX) */
/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NMAX) */
/* BF (workspace) REAL array, dimension (NMAX*NMAX) */
/* X (workspace) REAL array, dimension (4*NMAX) */
/* RWORK (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) REAL 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 SLATMS 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;
--nval;
--pval;
--mval;
/* 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 SLATMS. */
slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
distb);
slatms_(&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;
}
slatms_(&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__) {
x[i__] = slarnd_(&c__2, &iseed[1]);
/* L20: */
}
sglmts_(&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 SCKGLM */
} /* sckglm_ */
/* Subroutine */ int zdrgsx_(integer *nsize, integer *ncmax, doublereal *
thresh, integer *nin, integer *nout, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *ai, doublecomplex *bi, doublecomplex
*z__, doublecomplex *q, doublecomplex *alpha, doublecomplex *beta,
doublecomplex *c__, integer *ldc, doublereal *s, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *iwork, integer *liwork,
logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 ZDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Complex Expert Generalized Sch"
"ur form\002,\002 problem driver\002)";
static char fmt_9994[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,d10.4)";
static char fmt_9998[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9995[] = "(\002Input Example\002)";
static char fmt_9990[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double d_imag(doublecomplex *);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublereal temp1, temp2;
static integer i__, j;
static doublereal abnrm;
static integer ifunc, linfo;
static char sense[1];
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *);
static integer nerrs, ntest;
static doublereal pltru;
extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static logical ilabad;
static doublereal thrsh2;
extern /* Subroutine */ int zlatm5_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
static integer mm, bdspac;
static doublereal pl[2];
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static doublereal weight, diftru;
extern /* Subroutine */ int zgesvd_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer minwrk, maxwrk;
extern /* Subroutine */ int zggesx_(char *, char *, char *, L_fp, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *, integer *,
logical *, integer *);
static doublereal smlnum;
static integer mn2, nptknt;
static doublereal ulpinv, result[10];
static integer ntestt, prtype;
extern logical zlctsx_();
static integer qba, qbb;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___39 = { 0, 0, 1, 0, 0 };
static cilist io___40 = { 0, 0, 1, 0, 0 };
static cilist io___41 = { 0, 0, 0, 0, 0 };
static cilist io___42 = { 0, 0, 0, 0, 0 };
static cilist io___43 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
#define ai_subscr(a_1,a_2) (a_2)*ai_dim1 + a_1
#define ai_ref(a_1,a_2) ai[ai_subscr(a_1,a_2)]
#define bi_subscr(a_1,a_2) (a_2)*bi_dim1 + a_1
#define bi_ref(a_1,a_2) bi[bi_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
ZDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
problem expert driver ZGGESX.
ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate
transpose, S and T are upper triangular (i.e., in generalized Schur
form), and Q and Z are unitary. It also computes the generalized
eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus,
w(j) = alpha(j)/beta(j) is a root of the characteristic equation
det( A - w(j) B ) = 0
Optionally it also reorders the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms; computes a reciprocal condition number for the average
of the selected eigenvalues; and computes a reciprocal condition
number for the right and left deflating subspaces corresponding to
the selected eigenvalues.
When ZDRGSX is called with NSIZE > 0, five (5) types of built-in
matrix pairs are used to test the routine ZGGESX.
When ZDRGSX is called with NSIZE = 0, it reads in test matrix data
to test ZGGESX.
(need more details on what kind of read-in data are needed).
For each matrix pair, the following tests will be performed and
compared with the threshhold THRESH except for the tests (7) and (9):
(1) | A - Q S Z' | / ( |A| n ulp )
(2) | B - Q T Z' | / ( |B| n ulp )
(3) | I - QQ' | / ( n ulp )
(4) | I - ZZ' | / ( n ulp )
(5) if A is in Schur form (i.e. triangular form)
(6) maximum over j of D(j) where:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
(7) if sorting worked and SDIM is the number of eigenvalues
which were selected.
(8) the estimated value DIF does not differ from the true values of
Difu and Difl more than a factor 10*THRESH. If the estimate DIF
equals zero the corresponding true values of Difu and Difl
should be less than EPS*norm(A, B). If the true value of Difu
and Difl equal zero, the estimate DIF should be less than
EPS*norm(A, B).
(9) If INFO = N+3 is returned by ZGGESX, the reordering "failed"
and we check that DIF = PL = PR = 0 and that the true value of
Difu and Difl is < EPS*norm(A, B). We count the events when
INFO=N+3.
For read-in test matrices, the same tests are run except that the
exact value for DIF (and PL) is input data. Additionally, there is
one more test run for read-in test matrices:
(10) the estimated value PL does not differ from the true value of
PLTRU more than a factor THRESH. If the estimate PL equals
zero the corresponding true value of PLTRU should be less than
EPS*norm(A, B). If the true value of PLTRU equal zero, the
estimate PL should be less than EPS*norm(A, B).
Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
matrix pairs are generated and tested. NSIZE should be kept small.
SVD (routine ZGESVD) is used for computing the true value of DIF_u
and DIF_l when testing the built-in test problems.
Built-in Test Matrices
======================
All built-in test matrices are the 2 by 2 block of triangular
matrices
A = [ A11 A12 ] and B = [ B11 B12 ]
[ A22 ] [ B22 ]
where for different type of A11 and A22 are given as the following.
A12 and B12 are chosen so that the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
have prescribed solution R and L.
Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
B11 = I_m, B22 = I_k
where J_k(a,b) is the k-by-k Jordan block with ``a'' on
diagonal and ``b'' on superdiagonal.
Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
second diagonal block in A_11 and each third diagonal block
in A_22 are made as 2 by 2 blocks.
Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
for i=1,...,m, j=1,...,m and
A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
for i=m+1,...,k, j=m+1,...,k
Type 5: (A,B) and have potentially close or common eigenvalues and
very large departure from block diagonality A_11 is chosen
as the m x m leading submatrix of A_1:
| 1 b |
| -b 1 |
| 1+d b |
| -b 1+d |
A_1 = | d 1 |
| -1 d |
| -d 1 |
| -1 -d |
| 1 |
and A_22 is chosen as the k x k leading submatrix of A_2:
| -1 b |
| -b -1 |
| 1-d b |
| -b 1-d |
A_2 = | d 1+b |
| -1-b d |
| -d 1+b |
| -1+b -d |
| 1-d |
and matrix B are chosen as identity matrices (see DLATM5).
Arguments
=========
NSIZE (input) INTEGER
The maximum size of the matrices to use. NSIZE >= 0.
If NSIZE = 0, no built-in tests matrices are used, but
read-in test matrices are used to test DGGESX.
NCMAX (input) INTEGER
Maximum allowable NMAX for generating Kroneker matrix
in call to ZLAKF2
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. THRESH >= 0.
NIN (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, B, AI, BI, Z and Q,
LDA >= max( 1, NSIZE ). For the read-in test,
LDA >= max( 1, N ), N is the size of the test matrices.
B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, B contains the last matrix actually used.
AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Copy of A, modified by ZGGESX.
BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Copy of B, modified by ZGGESX.
Z (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Z holds the left Schur vectors computed by ZGGESX.
Q (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Q holds the right Schur vectors computed by ZGGESX.
ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE)
BETA (workspace) COMPLEX*16 array, dimension (NSIZE)
On exit, ALPHA/BETA are the eigenvalues.
C (workspace) COMPLEX*16 array, dimension (LDC, LDC)
Store the matrix generated by subroutine ZLAKF2, this is the
matrix formed by Kronecker products used for estimating
DIF.
LDC (input) INTEGER
The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
S (workspace) DOUBLE PRECISION array, dimension (LDC)
Singular values of C
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 3*NSIZE*NSIZE/2
RWORK (workspace) DOUBLE PRECISION array,
dimension (5*NSIZE*NSIZE/2 - 4)
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= NSIZE + 2.
BWORK (workspace) LOGICAL array, dimension (NSIZE)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code.
=====================================================================
Check for errors
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1 * 1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1 * 1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--alpha;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--s;
--work;
--rwork;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -15;
} else if (*liwork < *nsize + 2) {
*info = -21;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = *nsize * 3 * *nsize / 2;
/* workspace for cggesx */
maxwrk = *nsize * (ilaenv_(&c__1, "ZGEQRF", " ", nsize, &c__1, nsize,
&c__0, (ftnlen)6, (ftnlen)1) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *nsize * (ilaenv_(&c__1, "ZUNGQR", " ", nsize, &
c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)1) + 1);
maxwrk = max(i__1,i__2);
/* workspace for zgesvd */
bdspac = *nsize * 3 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * *nsize * (ilaenv_(&c__1, "ZGEBRD",
" ", &i__3, &i__4, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1) + 1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = dlamch_("P");
ulpinv = 1. / ulp;
smlnum = dlamch_("S") / ulp;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs.
Loop over different functions (IFUNC) of ZGGESX, types (PRTYPE)
of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1. / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
&ai[ai_offset], lda);
zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
&bi[bi_offset], lda);
zlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1,
mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m +
1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
weight, &qba, &qbb);
/* Compute the Schur factorization and swapping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
Swapping is accomplished via the function ZLCTSX
which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
zggesx_("V", "V", "S", (L_fp)zlctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alpha[1], &beta[1], &q[q_offset], lda, &z__[
z_offset], lda, pl, difest, &work[1], lwork, &
rwork[1], &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "ZGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = zlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &rwork[1]);
/* Do tests (1) to (4) */
result[1] = 0.;
zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &rwork[1], result);
zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &rwork[1], &result[1]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &rwork[1], &result[2]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &rwork[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and
compare eigenvalues with diagonals. */
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = ai_subscr(j, j);
z__2.r = alpha[i__4].r - ai[i__5].r, z__2.i = alpha[
i__4].i - ai[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = bi_subscr(j, j);
z__4.r = beta[i__6].r - bi[i__7].r, z__4.i = beta[
i__6].i - bi[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = ai_subscr(j, j);
d__13 = smlnum, d__14 = (d__1 = alpha[i__8].r, abs(
d__1)) + (d__2 = d_imag(&alpha[j]), abs(d__2))
, d__13 = max(d__13,d__14), d__14 = (d__3 =
ai[i__9].r, abs(d__3)) + (d__4 = d_imag(&
ai_ref(j, j)), abs(d__4));
/* Computing MAX */
i__10 = j;
i__11 = bi_subscr(j, j);
d__15 = smlnum, d__16 = (d__5 = beta[i__10].r, abs(
d__5)) + (d__6 = d_imag(&beta[j]), abs(d__6)),
d__15 = max(d__15,d__16), d__16 = (d__7 = bi[
i__11].r, abs(d__7)) + (d__8 = d_imag(&bi_ref(
j, j)), abs(d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 =
d_imag(&z__1), abs(d__10))) / max(d__13,d__14)
+ ((d__11 = z__3.r, abs(d__11)) + (d__12 =
d_imag(&z__3), abs(d__12))) / max(d__15,d__16)
) / ulp;
if (j < mn_1.mplusn) {
i__4 = ai_subscr(j + 1, j);
if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
i__4 = ai_subscr(j, j - 1);
if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its
value. first, compute the exact DIF. */
result[7] = 0.;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two cases, there are
almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
zlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm +
1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1,
mm + 1), &c__[c_offset], ldc);
i__3 = *lwork - 2;
zgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, &rwork[1], info);
diftru = s[mn2];
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] /
diftru;
result[7] = max(d__1,d__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "CGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
/* Tests performed */
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
nptknt = 0;
L80:
io___39.ciunit = *nin;
i__1 = s_rsle(&io___39);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___40.ciunit = *nin;
i__1 = s_rsle(&io___40);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___41.ciunit = *nin;
s_rsle(&io___41);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___42.ciunit = *nin;
s_rsle(&io___42);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L100: */
}
io___43.ciunit = *nin;
s_rsle(&io___43);
do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alpha[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1], lwork, &rwork[1],
&iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "ZGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B)
(should this be norm of (A,B) or (AI,BI)?) */
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = zlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &
rwork[1]);
/* Do tests (1) to (4) */
zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], result);
zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
1]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &rwork[1], &result[2]
);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
3]);
/* Do tests (5) and (6): check Schur form of A and compare
eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
i__2 = j;
i__3 = ai_subscr(j, j);
z__2.r = alpha[i__2].r - ai[i__3].r, z__2.i = alpha[i__2].i - ai[i__3]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = j;
i__5 = bi_subscr(j, j);
z__4.r = beta[i__4].r - bi[i__5].r, z__4.i = beta[i__4].i - bi[i__5]
.i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__6 = j;
i__7 = ai_subscr(j, j);
d__13 = smlnum, d__14 = (d__1 = alpha[i__6].r, abs(d__1)) + (d__2 =
d_imag(&alpha[j]), abs(d__2)), d__13 = max(d__13,d__14),
d__14 = (d__3 = ai[i__7].r, abs(d__3)) + (d__4 = d_imag(&
ai_ref(j, j)), abs(d__4));
/* Computing MAX */
i__8 = j;
i__9 = bi_subscr(j, j);
d__15 = smlnum, d__16 = (d__5 = beta[i__8].r, abs(d__5)) + (d__6 =
d_imag(&beta[j]), abs(d__6)), d__15 = max(d__15,d__16), d__16
= (d__7 = bi[i__9].r, abs(d__7)) + (d__8 = d_imag(&bi_ref(j,
j)), abs(d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&z__1), abs(
d__10))) / max(d__13,d__14) + ((d__11 = z__3.r, abs(d__11)) +
(d__12 = d_imag(&z__3), abs(d__12))) / max(d__15,d__16)) /
ulp;
if (j < mn_1.mplusn) {
i__2 = ai_subscr(j + 1, j);
if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
i__2 = ai_subscr(j, j - 1);
if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.;
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
result[7] = max(d__1,d__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.;
if (pl[0] == 0.) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___48.ciunit = *nout;
s_wsfe(&io___48);
e_wsfe();
/* Tests performed */
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("CGX", nout, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGSX */
} /* zdrgsx_ */
/* Subroutine */ int cerred_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a,\002 passed the tests of the error exits"
" (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a,\002 failed the tests of the "
"error exits ***\002)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
char *, ftnlen), e_wsfe(void);
/* Local variables */
complex a[16] /* was [4][4] */;
logical b[4];
integer i__, j;
real s[4];
complex u[16] /* was [4][4] */, w[16], x[4];
char c2[2];
real r1[4], r2[4];
integer iw[16], nt;
complex vl[16] /* was [4][4] */, vr[16] /* was [4][4] */;
real rw[20];
complex vt[16] /* was [4][4] */;
integer ihi, ilo, info, sdim;
extern /* Subroutine */ int cgees_(char *, char *, L_fp, integer *,
complex *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, real *, logical *, integer *), cgeev_(char *, char *, integer *, complex *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
real abnrm;
extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex
*, integer *, real *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *, integer *),
cgesvd_(char *, char *, integer *, integer *, complex *, integer *
, real *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
extern logical cslect_();
extern /* Subroutine */ int cgeesx_(char *, char *, L_fp, char *, integer
*, complex *, integer *, integer *, complex *, complex *, integer
*, real *, real *, complex *, integer *, real *, logical *,
integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int cgeevx_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *, integer *, real *, real *, real *
, real *, complex *, integer *, real *, integer *), chkxer_(char *, integer *, integer *, logical *,
logical *);
/* Fortran I/O blocks */
static cilist io___1 = { 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___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRED tests the error exits for the eigenvalue driver routines for */
/* REAL matrices: */
/* PATH driver description */
/* ---- ------ ----------- */
/* CEV CGEEV find eigenvalues/eigenvectors for nonsymmetric A */
/* CES CGEES find eigenvalues/Schur form for nonsymmetric A */
/* CVX CGEEVX CGEEV + balancing and condition estimation */
/* CSX CGEESX CGEES + balancing and condition estimation */
/* CBD CGESVD compute SVD of an M-by-N matrix A */
/* CGESDD compute SVD of an M-by-N matrix A(by divide and */
/* conquer) */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. 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);
/* Initialize A */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
a[i__1].r = 0.f, a[i__1].i = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (i__ << 2) - 5;
a[i__1].r = 1.f, a[i__1].i = 0.f;
/* L30: */
}
infoc_1.ok = TRUE_;
nt = 0;
if (lsamen_(&c__2, c2, "EV")) {
/* Test CGEEV */
s_copy(srnamc_1.srnamt, "CGEEV ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeev_("X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeev_("N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgeev_("N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cgeev_("N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__4,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cgeev_("V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgeev_("N", "V", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cgeev_("V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
rw, &info);
chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "ES")) {
/* Test CGEES */
s_copy(srnamc_1.srnamt, "CGEES ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgees_("X", "N", (L_fp)cslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
w, &c__1, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgees_("N", "X", (L_fp)cslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
w, &c__1, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgees_("N", "S", (L_fp)cslect_, &c_n1, a, &c__1, &sdim, x, vl, &c__1,
w, &c__1, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
cgees_("N", "S", (L_fp)cslect_, &c__2, a, &c__1, &sdim, x, vl, &c__1,
w, &c__4, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgees_("V", "S", (L_fp)cslect_, &c__2, a, &c__2, &sdim, x, vl, &c__1,
w, &c__4, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cgees_("N", "S", (L_fp)cslect_, &c__1, a, &c__1, &sdim, x, vl, &c__1,
w, &c__1, rw, b, &info);
chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
} else if (lsamen_(&c__2, c2, "VX")) {
/* Test CGEEVX */
s_copy(srnamc_1.srnamt, "CGEEVX", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeevx_("X", "N", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeevx_("N", "X", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgeevx_("N", "N", "X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeevx_("N", "N", "N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cgeevx_("N", "N", "N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgeevx_("N", "V", "N", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cgeevx_("N", "N", "V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 20;
cgeevx_("N", "N", "N", "N", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 20;
cgeevx_("N", "N", "V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
&ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, rw, &info);
chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
} else if (lsamen_(&c__2, c2, "SX")) {
/* Test CGEESX */
s_copy(srnamc_1.srnamt, "CGEESX", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgeesx_("X", "N", (L_fp)cslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__1, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgeesx_("N", "X", (L_fp)cslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__1, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgeesx_("N", "N", (L_fp)cslect_, "X", &c__0, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__1, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cgeesx_("N", "N", (L_fp)cslect_, "N", &c_n1, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__1, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cgeesx_("N", "N", (L_fp)cslect_, "N", &c__2, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__4, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
cgeesx_("V", "N", (L_fp)cslect_, "N", &c__2, a, &c__2, &sdim, x, vl, &
c__1, r1, r2, w, &c__4, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
cgeesx_("N", "N", (L_fp)cslect_, "N", &c__1, a, &c__1, &sdim, x, vl, &
c__1, r1, r2, w, &c__1, rw, b, &info);
chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "BD")) {
/* Test CGESVD */
s_copy(srnamc_1.srnamt, "CGESVD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
cgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
cgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
c__5, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
cgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, rw, &info);
chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
if (infoc_1.ok) {
io___23.ciunit = infoc_1.nout;
s_wsfe(&io___23);
do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
ftnlen)32));
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___24.ciunit = infoc_1.nout;
s_wsfe(&io___24);
e_wsfe();
}
/* Test CGESDD */
s_copy(srnamc_1.srnamt, "CGESDD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
rw, iw, &info);
chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += -2;
if (infoc_1.ok) {
io___26.ciunit = infoc_1.nout;
s_wsfe(&io___26);
do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
ftnlen)32));
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___27.ciunit = infoc_1.nout;
s_wsfe(&io___27);
e_wsfe();
}
}
/* Print a summary line. */
if (! lsamen_(&c__2, c2, "BD")) {
if (infoc_1.ok) {
io___28.ciunit = infoc_1.nout;
s_wsfe(&io___28);
do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
ftnlen)32));
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___29.ciunit = infoc_1.nout;
s_wsfe(&io___29);
e_wsfe();
}
}
return 0;
/* End of CERRED */
} /* cerred_ */
/* Subroutine */ int alaesm_(char *path, logical *ok, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
/* -- 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
=======
ALAESM prints a summary of results from one of the -ERR- routines.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name.
OK (input) LOGICAL
The flag from CHKXER that indicates whether or not the tests
of error exits passed.
NOUT (input) INTEGER
The unit number on which results are to be printed.
NOUT >= 0.
===================================================================== */
if (*ok) {
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else {
io___2.ciunit = *nout;
s_wsfe(&io___2);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ALAESM */
} /* alaesm_ */
/* Subroutine */ int ddrvls_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nns, integer *nsval, integer *
nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
tsterr, doublereal *a, doublereal *copya, doublereal *b, doublereal *
copyb, doublereal *c__, doublereal *s, doublereal *copys, doublereal *
work, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
"=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
"\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal), log(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info;
static char path[3];
static integer rank, nrhs, nlvl, nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer m, n;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer nfail, iseed[4];
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer crank;
extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer irank;
static doublereal rcond;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer itran, mnmin, ncols;
static doublereal norma, normb;
extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dqrt14_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dqrt17_(char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static char trans[1];
static integer nerrs, itype;
extern /* Subroutine */ int dqrt13_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer lwork;
extern /* Subroutine */ int dqrt15_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dqrt16_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nrows, lwlsy, nb, im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iscale;
extern /* Subroutine */ int dgelsd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlacpy_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *), dgelss_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dgelsx_(integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *),
dgelsy_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), derrls_(char *, integer *),
xlaenv_(integer *, integer *);
static integer ldwork;
static doublereal result[18];
static integer lda, ldb, inb;
static doublereal eps;
static integer ins;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
January 3, 2000
Purpose
=======
DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX,
DGELSY and DGELSD.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
The matrix of type j is generated as follows:
j=1: A = U*D*V where U and V are random orthogonal matrices
and D has random entries (> 0.1) taken from a uniform
distribution (0,1). A is full rank.
j=2: The same of 1, but A is scaled up.
j=3: The same of 1, but A is scaled down.
j=4: A = U*D*V where U and V are random orthogonal matrices
and D has 3*min(M,N)/4 random entries (> 0.1) taken
from a uniform distribution (0,1) and the remaining
entries set to 0. A is rank-deficient.
j=5: The same of 4, but A is scaled up.
j=6: The same of 5, but A is scaled down.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
NNB (input) INTEGER
The number of values of NB 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.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
where MMAX is the maximum value of M in MVAL and NSMAX is the
maximum value of NRHS in NSVAL.
COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
C (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
WORK (workspace) DOUBLE PRECISION array,
dimension (MMAX*NMAX + 4*NMAX + MMAX).
IWORK (workspace) INTEGER array, dimension (15*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--copys;
--s;
--c__;
--copyb;
--b;
--copya;
--a;
--nxval;
--nbval;
--nsval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Threshold for rank estimation */
rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
/* Test the error exits */
if (*tsterr) {
derrls_(path, nout);
}
/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
alahd_(nout, path);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
xlaenv_(&c__9, &c__25);
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = max(1,m);
ldb = max(i__3,n);
i__3 = *nns;
for (ins = 1; ins <= i__3; ++ins) {
nrhs = nsval[ins];
/* Computing MAX
Computing MAX */
d__1 = 1., d__2 = (doublereal) mnmin;
i__4 = (integer) (log(max(d__1,d__2) / 26.) / log(2.)) + 1;
nlvl = max(i__4,0);
/* Computing MAX */
i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
i__4,i__5), i__5 = mnmin * 12 + mnmin * 50 + (mnmin <<
3) * nlvl + mnmin * nrhs + 676;
lwork = max(i__4,i__5);
for (irank = 1; irank <= 2; ++irank) {
for (iscale = 1; iscale <= 3; ++iscale) {
itype = (irank - 1) * 3 + iscale;
if (! dotype[itype]) {
goto L110;
}
if (irank == 1) {
/* Test DGELS
Generate a matrix of scaling type ISCALE */
dqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
iseed);
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)trans = 'N';
nrows = m;
ncols = n;
} else {
*(unsigned char *)trans = 'T';
nrows = n;
ncols = m;
}
ldwork = max(1,ncols);
/* Set up a consistent rhs */
if (ncols > 0) {
i__5 = ncols * nrhs;
dlarnv_(&c__2, iseed, &i__5, &work[1])
;
i__5 = ncols * nrhs;
d__1 = 1. / (doublereal) ncols;
dscal_(&i__5, &d__1, &work[1], &c__1);
}
dgemm_(trans, "No transpose", &nrows, &
nrhs, &ncols, &c_b24, ©a[1], &
lda, &work[1], &ldwork, &c_b25, &
b[1], &ldb)
;
dlacpy_("Full", &nrows, &nrhs, &b[1], &
ldb, ©b[1], &ldb);
/* Solve LS or overdetermined system */
if (m > 0 && n > 0) {
dlacpy_("Full", &m, &n, ©a[1], &
lda, &a[1], &lda);
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &b[1], &ldb);
}
s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)
6, (ftnlen)6);
dgels_(trans, &m, &n, &nrhs, &a[1], &lda,
&b[1], &ldb, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELS ", &info, &c__0,
trans, &m, &n, &nrhs, &c_n1, &
nb, &itype, &nfail, &nerrs,
nout);
}
/* Check correctness of results */
ldwork = max(1,nrows);
if (nrows > 0 && nrhs > 0) {
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &c__[1], &ldb);
}
dqrt16_(trans, &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &c__[1], &ldb, &
work[1], result);
if (itran == 1 && m >= n || itran == 2 &&
m < n) {
/* Solving LS system */
result[1] = dqrt17_(trans, &c__1, &m,
&n, &nrhs, ©a[1], &lda, &
b[1], &ldb, ©b[1], &ldb, &
c__[1], &work[1], &lwork);
} else {
/* Solving overdetermined system */
result[1] = dqrt14_(trans, &m, &n, &
nrhs, ©a[1], &lda, &b[1],
&ldb, &work[1], &lwork);
}
/* Print information about the tests that
did not pass the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, trans, (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 *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itype, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 2;
/* L30: */
}
/* L40: */
}
}
/* Generate a matrix of scaling type ISCALE and rank
type IRANK. */
dqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
lda, ©b[1], &ldb, ©s[1], &rank, &
norma, &normb, iseed, &work[1], &lwork);
/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
Initialize vector IWORK. */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
iwork[j] = 0;
/* L50: */
}
ldwork = max(1,m);
/* Test DGELSX
DGELSX: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a complete
orthogonal factorization. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
ldb);
s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)6, (ftnlen)
6);
dgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &info);
if (info != 0) {
alaerh_(path, "DGELSX", &info, &c__0, " ", &m, &n,
&nrhs, &c_n1, &nb, &itype, &nfail, &
nerrs, nout);
}
/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
Test 3: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[2] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 4: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
&ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &work[1], &ldwork, &work[m *
nrhs + 1], &result[3]);
/* Test 5: Check norm of r'*A
workspace: NRHS*(M+N) */
result[4] = 0.;
if (m > crank) {
result[4] = dqrt17_("No transpose", &c__1, &m, &n,
&nrhs, ©a[1], &lda, &b[1], &ldb, &
copyb[1], &ldb, &c__[1], &work[1], &lwork);
}
/* Test 6: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[5] = 0.;
if (n > crank) {
result[5] = dqrt14_("No transpose", &m, &n, &nrhs,
©a[1], &lda, &b[1], &ldb, &work[1], &
lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 3; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 4;
/* Loop for testing different block sizes. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
/* Test DGELSY
DGELSY: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the rank-revealing orthogonal
factorization.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L70: */
}
/* Set LWLSY to the adequate value.
Computing MAX */
i__5 = 1, i__6 = mnmin + (n << 1) + nb * (n + 1),
i__5 = max(i__5,i__6), i__6 = (mnmin << 1)
+ nb * nrhs;
lwlsy = max(i__5,i__6);
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)6, (
ftnlen)6);
dgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &
lwlsy, &info);
if (info != 0) {
alaerh_(path, "DGELSY", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 7: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[6] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 8: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[7]);
/* Test 9: Check norm of r'*A
workspace: NRHS*(M+N) */
result[8] = 0.;
if (m > crank) {
result[8] = dqrt17_("No transpose", &c__1, &m,
&n, &nrhs, ©a[1], &lda, &b[1], &
ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 10: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[9] = 0.;
if (n > crank) {
result[9] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSS
DGELSS: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the SVD. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)6, (
ftnlen)6);
dgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELSS", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 3*min(m,n) +
max(2*min(m,n),nrhs,max(m,n))
Test 11: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[10] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[10] = 0.;
}
/* Test 12: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[11]);
/* Test 13: Check norm of r'*A */
result[12] = 0.;
if (m > crank) {
result[12] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 14: Check if x is in the rowspace of A */
result[13] = 0.;
if (n > crank) {
result[13] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSD
DGELSD: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a
divide and conquer SVD.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L80: */
}
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)6, (
ftnlen)6);
dgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
iwork[1], &info);
if (info != 0) {
alaerh_(path, "DGELSD", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 15: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[14] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[14] = 0.;
}
/* Test 16: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[15]);
/* Test 17: Check norm of r'*A */
result[16] = 0.;
if (m > crank) {
result[16] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 18: Check if x is in the rowspace of A */
result[17] = 0.;
if (n > crank) {
result[17] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 7; k <= 18; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun += 12;
/* L100: */
}
L110:
;
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVLS */
} /* ddrvls_ */
/* Subroutine */ int slahd2_(integer *iounit, char *path)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002: no header available\002)";
static char fmt_9998[] = "(/1x,a3,\002 -- Real Non-symmetric eigenvalue "
"problem\002)";
static char fmt_9988[] = "(\002 Matrix types (see xCHKHS for details):"
" \002)";
static char fmt_9987[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9986[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
"/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
"Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
"\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
"d.\002,\002 complx \002,a4)";
static char fmt_9985[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002)";
static char fmt_9984[] = "(/\002 Tests performed: \002,\002(H is Hesse"
"nberg, T is Schur,\002,\002 U and Z are \002,a,\002,\002,/20x,a"
",\002, W is a diagonal matr\002,\002ix of eigenvalues,\002,/20x"
",\002L and R are the left and rig\002,\002ht eigenvector matrice"
"s)\002,/\002 1 = | A - U H U\002,a1,\002 |\002,\002 / ( |A| n u"
"lp ) \002,\002 2 = | I - U U\002,a1,\002 | / \002,\002("
" n ulp )\002,/\002 3 = | H - Z T Z\002,a1,\002 | / ( |H| n ulp"
" \002,\002) \002,\002 4 = | I - Z Z\002,a1,\002 | / ( n"
" ulp )\002,/\002 5 = | A - UZ T (UZ)\002,a1,\002 | / ( |A| n ul"
"p ) \002,\002 6 = | I - UZ (UZ)\002,a1,\002 | / ( n ulp "
")\002,/\002 7 = | T(\002,\002e.vects.) - T(no e.vects.) | / ( |"
"T| ulp )\002,/\002 8 = | W\002,\002(e.vects.) - W(no e.vects.) "
"| / ( |W| ulp )\002,/\002 9 = | \002,\002TR - RW | / ( |T| |R| "
"ulp ) \002,\002 10 = | LT - WL | / (\002,\002 |T| |L| ulp "
")\002,/\002 11= |HX - XW| / (|H| |X| ulp) (inv.\002,\002it)\002,"
"\002 12= |YH - WY| / (|H| |Y| ulp) (inv.it)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Non-symmetric eigenval"
"ue problem\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Real Symmetric eigenvalue prob"
"lem\002)";
static char fmt_9983[] = "(\002 Matrix types (see xDRVST for details):"
" \002)";
static char fmt_9982[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: clus"
"tered entries.\002,/\002 2=\002,\002Identity matrix. "
" \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
"\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
"agonal: geometr. spaced entries.\002)";
static char fmt_9981[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
"=Evenly spaced eigen\002,\002vals. \002,\002 12=Small"
", evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eig"
"envals. \002,\002 13=Matrix \002,\002with random O(1) entrie"
"s.\002,/\002 10=Clustered eigenvalues.\002,\002 "
"\002,\002 14=Matrix with large random entries.\002,/\002 11=Larg"
"e, evenly spaced eigenvals. \002,\002 15=Matrix \002,\002wit"
"h small random entries.\002)";
static char fmt_9968[] = "(/\002 Tests performed: See sdrvst.f\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Complex Hermitian eigenvalue p"
"roblem\002)";
static char fmt_9967[] = "(/\002 Tests performed: See cdrvst.f\002)";
static char fmt_9992[] = "(/1x,a3,\002 -- Real Symmetric Generalized eig"
"envalue \002,\002problem\002)";
static char fmt_9980[] = "(\002 Matrix types (see xDRVSG for details):"
" \002)";
static char fmt_9979[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: clus"
"tered entries.\002,/\002 2=\002,\002Identity matrix. "
" \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
"\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
"agonal: geometr. spaced entries.\002)";
static char fmt_9978[] = "(\002 Dense or Banded \002,a,\002 Matrices:"
" \002,/\002 8=Evenly spaced eigenvals. \002,\002 15=Mat"
"rix with small random entries.\002,/\002 9=Geometrically spaced"
" eigenvals. \002,\002 16=Evenly spaced eigenvals, KA=1, KB=1"
".\002,/\002 10=Clustered eigenvalues. \002,\002 17=Eve"
"nly spaced eigenvals, KA=2, KB=1.\002,/\002 11=Large, evenly spa"
"ced eigenvals. \002,\002 18=Evenly spaced eigenvals, KA=2, KB=2."
"\002,/\002 12=Small, evenly spaced eigenvals. \002,\002 19=Even"
"ly spaced eigenvals, KA=3, KB=1.\002,/\002 13=Matrix with random"
" O(1) entries. \002,\002 20=Evenly spaced eigenvals, KA=3, KB=2"
".\002,/\002 14=Matrix with large random entries.\002,\002 21=Eve"
"nly spaced eigenvals, KA=3, KB=3.\002)";
static char fmt_9977[] = "(/\002 Tests performed: \002,/\002( For each"
" pair (A,B), where A is of the given type \002,/\002 and B is a "
"random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
"is orthogonal. )\002,/\002 1 = SSYGV, with ITYPE=1 and UPLO='U'"
":\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2"
" = SSPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | /"
" ( |A| |Z| n ulp ) \002,/\002 3 = SSBGV, with ITYPE=1 and UP"
"LO='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
"/\002 4 = SSYGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
"Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = SSPGV, with ITYPE=1"
" and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
"\002,/\002 6 = SSBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
" - B Z D | / ( |A| |Z| n ulp ) \002)";
static char fmt_9976[] = "(\002 7 = SSYGV, with ITYPE=2 and UPLO='U':"
"\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
"= SSPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
"( |A| |Z| n ulp ) \002,/\002 9 = SSPGV, with ITYPE=2 and UPL"
"O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
"/\00210 = SSPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
"Z D | / ( |A| |Z| n ulp ) \002,/\00211 = SSYGV, with ITYPE=3"
" and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
"\002,/\00212 = SSPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
" Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = SSYGV, with IT"
"YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
") \002,/\00214 = SSPGV, with ITYPE=3 and UPLO='L':\002,\002 "
" | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
static char fmt_9991[] = "(/1x,a3,\002 -- Complex Hermitian Generalized "
"eigenvalue \002,\002problem\002)";
static char fmt_9975[] = "(/\002 Tests performed: \002,/\002( For each"
" pair (A,B), where A is of the given type \002,/\002 and B is a "
"random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
"is unitary. )\002,/\002 1 = CHEGV, with ITYPE=1 and UPLO='U':"
"\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2 "
"= CHPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | / "
"( |A| |Z| n ulp ) \002,/\002 3 = CHBGV, with ITYPE=1 and UPL"
"O='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
"/\002 4 = CHEGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
"Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = CHPGV, with ITYPE=1"
" and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
"\002,/\002 6 = CHBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
" - B Z D | / ( |A| |Z| n ulp ) \002)";
static char fmt_9974[] = "(\002 7 = CHEGV, with ITYPE=2 and UPLO='U':"
"\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
"= CHPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
"( |A| |Z| n ulp ) \002,/\002 9 = CHPGV, with ITYPE=2 and UPL"
"O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
"/\00210 = CHPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
"Z D | / ( |A| |Z| n ulp ) \002,/\00211 = CHEGV, with ITYPE=3"
" and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
"\002,/\00212 = CHPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
" Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = CHEGV, with IT"
"YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
") \002,/\00214 = CHPGV, with ITYPE=3 and UPLO='L':\002,\002 "
" | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
static char fmt_9994[] = "(/1x,a3,\002 -- Real Singular Value Decomposit"
"ion\002)";
static char fmt_9973[] = "(\002 Matrix types (see xCHKBD for details)"
":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
"5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
"ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
"s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
"ometrically spaced entries\002,/\002 General matrices:\002,/\002"
" 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
"ced sing vals\002,/\002 9: Geometrically spaced sing vals "
"\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
" vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
"1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
"ear underflow\002)";
static char fmt_9972[] = "(/\002 Test ratios: \002,\002(B: bidiagonal, "
"S: diagonal, Q, P, U, and V: \002,a10,/16x,\002X: m x nrhs, Y = "
"Q' X, and Z = U' Y)\002,/\002 1: norm( A - Q B P' ) / ( norm(A"
") max(m,n) ulp )\002,/\002 2: norm( I - Q' Q ) / ( m ulp "
")\002,/\002 3: norm( I - P' P ) / ( n ulp )\002,/\002 4: n"
"orm( B - U S V' ) / ( norm(B) min(m,n) ulp )\002,/\002 5: norm"
"( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )\002,/\002 6: "
"norm( I - U' U ) / ( min(m,n) ulp )\002,/\002 7: norm( I - V"
"' V ) / ( min(m,n) ulp )\002)";
static char fmt_9971[] = "(\002 8: Test ordering of S (0 if nondecrea"
"sing, 1/ulp \002,\002 otherwise)\002,/\002 9: norm( S - S2 ) "
" / ( norm(S) ulp ),\002,\002 where S2 is computed\002,/44x,"
"\002without computing U and V'\002,/\002 10: Sturm sequence tes"
"t \002,\002(0 if sing. vals of B within THRESH of S)\002,/\002 "
"11: norm( A - (QU) S (V' P') ) / \002,\002( norm(A) max(m,n) ulp"
" )\002,/\002 12: norm( X - (QU) Z ) / ( |X| max(M,k) ul"
"p )\002,/\002 13: norm( I - (QU)'(QU) ) / ( M ulp )\002,"
"/\002 14: norm( I - (V' P') (P V) ) / ( N ulp )\002)";
static char fmt_9993[] = "(/1x,a3,\002 -- Complex Singular Value Decompo"
"sition\002)";
static char fmt_9990[] = "(/1x,a3,\002 -- Real Band reduc. to bidiagonal"
" form\002)";
static char fmt_9970[] = "(\002 Matrix types (see xCHKBB for details)"
":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
"5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
"ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
"s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
"ometrically spaced entries\002,/\002 General matrices:\002,/\002"
" 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
"ced sing vals\002,/\002 9: Geometrically spaced sing vals "
"\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
" vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
"1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
"ear underflow\002)";
static char fmt_9969[] = "(/\002 Test ratios: \002,\002(B: upper bidiag"
"onal, Q and P: \002,a10,/16x,\002C: m x nrhs, PT = P', Y = Q' C"
")\002,/\002 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )\002"
",/\002 2: norm( I - Q' Q ) / ( m ulp )\002,/\002 3: norm( I - "
"PT PT' ) / ( n ulp )\002,/\002 4: norm( Y - Q' C ) / ( norm("
"Y) max(m,nrhs) ulp )\002)";
static char fmt_9989[] = "(/1x,a3,\002 -- Complex Band reduc. to bidiago"
"nal form\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static logical sord, corz;
static integer j;
extern logical lsame_(char *, char *);
static char c2[2];
extern logical lsamen_(integer *, char *, char *);
/* Fortran I/O blocks */
static cilist io___3 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___5 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___7 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9985, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9984, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9985, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9984, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9983, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9982, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9981, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9968, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9983, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9982, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9981, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9967, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9980, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9979, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9978, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9977, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9976, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9980, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9979, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9978, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9975, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9974, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9973, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9972, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9971, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9973, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9972, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9971, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9970, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9969, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9970, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9969, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLAHD2 prints header information for the different test paths.
Arguments
=========
IOUNIT (input) INTEGER.
On entry, IOUNIT specifies the unit number to which the
header information should be printed.
PATH (input) CHARACTER*3.
On entry, PATH contains the name of the path for which the
header information is to be printed. Current paths are
SHS, CHS: Non-symmetric eigenproblem.
SST, CST: Symmetric eigenproblem.
SSG, CSG: Symmetric Generalized eigenproblem.
SBD, CBD: Singular Value Decomposition (SVD)
SBB, CBB: General Banded reduction to bidiagonal form
These paths also are supplied in double precision (replace
leading S by D and leading C by Z in path names).
===================================================================== */
if (*iounit <= 0) {
return 0;
}
sord = lsame_(path, "S") || lsame_(path, "D");
corz = lsame_(path, "C") || lsame_(path, "Z");
if (! sord && ! corz) {
io___3.ciunit = *iounit;
s_wsfe(&io___3);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
if (lsamen_(&c__2, c2, "HS")) {
if (sord) {
/* Real Non-symmetric Eigenvalue Problem: */
io___5.ciunit = *iounit;
s_wsfe(&io___5);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___6.ciunit = *iounit;
s_wsfe(&io___6);
e_wsfe();
io___7.ciunit = *iounit;
s_wsfe(&io___7);
e_wsfe();
io___8.ciunit = *iounit;
s_wsfe(&io___8);
do_fio(&c__1, "pairs ", (ftnlen)6);
do_fio(&c__1, "pairs ", (ftnlen)6);
do_fio(&c__1, "prs.", (ftnlen)4);
do_fio(&c__1, "prs.", (ftnlen)4);
e_wsfe();
io___9.ciunit = *iounit;
s_wsfe(&io___9);
e_wsfe();
/* Tests performed */
io___10.ciunit = *iounit;
s_wsfe(&io___10);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'=transpose", (ftnlen)11);
for (j = 1; j <= 6; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
} else {
/* Complex Non-symmetric Eigenvalue Problem: */
io___12.ciunit = *iounit;
s_wsfe(&io___12);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___13.ciunit = *iounit;
s_wsfe(&io___13);
e_wsfe();
io___14.ciunit = *iounit;
s_wsfe(&io___14);
e_wsfe();
io___15.ciunit = *iounit;
s_wsfe(&io___15);
do_fio(&c__1, "e.vals", (ftnlen)6);
do_fio(&c__1, "e.vals", (ftnlen)6);
do_fio(&c__1, "e.vs", (ftnlen)4);
do_fio(&c__1, "e.vs", (ftnlen)4);
e_wsfe();
io___16.ciunit = *iounit;
s_wsfe(&io___16);
e_wsfe();
/* Tests performed */
io___17.ciunit = *iounit;
s_wsfe(&io___17);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*=conj.transp.", (ftnlen)14);
for (j = 1; j <= 6; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "ST")) {
if (sord) {
/* Real Symmetric Eigenvalue Problem: */
io___18.ciunit = *iounit;
s_wsfe(&io___18);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___19.ciunit = *iounit;
s_wsfe(&io___19);
e_wsfe();
io___20.ciunit = *iounit;
s_wsfe(&io___20);
e_wsfe();
io___21.ciunit = *iounit;
s_wsfe(&io___21);
do_fio(&c__1, "Symmetric", (ftnlen)9);
e_wsfe();
/* Tests performed */
io___22.ciunit = *iounit;
s_wsfe(&io___22);
e_wsfe();
} else {
/* Complex Hermitian Eigenvalue Problem: */
io___23.ciunit = *iounit;
s_wsfe(&io___23);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___24.ciunit = *iounit;
s_wsfe(&io___24);
e_wsfe();
io___25.ciunit = *iounit;
s_wsfe(&io___25);
e_wsfe();
io___26.ciunit = *iounit;
s_wsfe(&io___26);
do_fio(&c__1, "Hermitian", (ftnlen)9);
e_wsfe();
/* Tests performed */
io___27.ciunit = *iounit;
s_wsfe(&io___27);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "SG")) {
if (sord) {
/* Real Symmetric Generalized Eigenvalue Problem: */
io___28.ciunit = *iounit;
s_wsfe(&io___28);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___29.ciunit = *iounit;
s_wsfe(&io___29);
e_wsfe();
io___30.ciunit = *iounit;
s_wsfe(&io___30);
e_wsfe();
io___31.ciunit = *iounit;
s_wsfe(&io___31);
do_fio(&c__1, "Symmetric", (ftnlen)9);
e_wsfe();
/* Tests performed */
io___32.ciunit = *iounit;
s_wsfe(&io___32);
e_wsfe();
io___33.ciunit = *iounit;
s_wsfe(&io___33);
e_wsfe();
} else {
/* Complex Hermitian Generalized Eigenvalue Problem: */
io___34.ciunit = *iounit;
s_wsfe(&io___34);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___35.ciunit = *iounit;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *iounit;
s_wsfe(&io___36);
e_wsfe();
io___37.ciunit = *iounit;
s_wsfe(&io___37);
do_fio(&c__1, "Hermitian", (ftnlen)9);
e_wsfe();
/* Tests performed */
io___38.ciunit = *iounit;
s_wsfe(&io___38);
e_wsfe();
io___39.ciunit = *iounit;
s_wsfe(&io___39);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "BD")) {
if (sord) {
/* Real Singular Value Decomposition: */
io___40.ciunit = *iounit;
s_wsfe(&io___40);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___41.ciunit = *iounit;
s_wsfe(&io___41);
e_wsfe();
/* Tests performed */
io___42.ciunit = *iounit;
s_wsfe(&io___42);
do_fio(&c__1, "orthogonal", (ftnlen)10);
e_wsfe();
io___43.ciunit = *iounit;
s_wsfe(&io___43);
e_wsfe();
} else {
/* Complex Singular Value Decomposition: */
io___44.ciunit = *iounit;
s_wsfe(&io___44);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___45.ciunit = *iounit;
s_wsfe(&io___45);
e_wsfe();
/* Tests performed */
io___46.ciunit = *iounit;
s_wsfe(&io___46);
do_fio(&c__1, "unitary ", (ftnlen)10);
e_wsfe();
io___47.ciunit = *iounit;
s_wsfe(&io___47);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "BB")) {
if (sord) {
/* Real General Band reduction to bidiagonal form: */
io___48.ciunit = *iounit;
s_wsfe(&io___48);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *iounit;
s_wsfe(&io___49);
e_wsfe();
/* Tests performed */
io___50.ciunit = *iounit;
s_wsfe(&io___50);
do_fio(&c__1, "orthogonal", (ftnlen)10);
e_wsfe();
} else {
/* Complex Band reduction to bidiagonal form: */
io___51.ciunit = *iounit;
s_wsfe(&io___51);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *iounit;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *iounit;
s_wsfe(&io___53);
do_fio(&c__1, "unitary ", (ftnlen)10);
e_wsfe();
}
} else {
io___54.ciunit = *iounit;
s_wsfe(&io___54);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
return 0;
}
return 0;
/* Symmetric/Hermitian eigenproblem
Symmetric/Hermitian Generalized eigenproblem
Singular Value Decomposition
Band reduction to bidiagonal form
End of SLAHD2 */
} /* slahd2_ */
/* Subroutine */ int zchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)";
static char fmt_9998[] = "(\002 ratio of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(\002 example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
" = \002,i4)";
static char fmt_9995[] = "(\002 example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(\002 number of examples where info is not 0 "
" = \002,i4)";
static char fmt_9993[] = "(\002 total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
doublecomplex z__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[3];
static doublereal rmax, vmax, work[120];
static doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][
20] */;
static integer i__, j, n, ihiin, ninfo, iloin;
static doublereal anorm, bnorm;
extern doublereal dlamch_(char *);
static doublereal lscale[20];
extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
static doublereal rscale[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal lsclin[20], rsclin[20];
static doublecomplex ain[400] /* was [20][20] */, bin[400] /*
was [20][20] */;
static integer ihi, ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
#define a_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define ain_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define ain_ref(a_1,a_2) ain[ain_subscr(a_1,a_2)]
#define bin_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define bin_ref(a_1,a_2) bin[bin_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bin_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, work);
bnorm = zlange_("M", &n, &n, b, &c__20, work);
++knt;
zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = a_subscr(i__, j);
i__4 = ain_subscr(i__, j);
z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* Computing MAX */
i__3 = b_subscr(i__, j);
i__4 = bin_subscr(i__, j);
z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGL */
} /* zchkgl_ */
/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd,
doublereal *eps, integer *emin, doublereal *rmin, integer *emax,
doublereal *rmax)
{
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* Format strings */
static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
"ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
"lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
" the IF block as marked within the code of routine\002,\002 DLAM"
"C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double pow_di(doublereal *, integer *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublereal a, b, c__;
integer i__;
static integer lt;
doublereal one, two;
logical ieee;
doublereal half;
logical lrnd;
static doublereal leps;
doublereal zero;
static integer lbeta;
doublereal rbase;
static integer lemin, lemax;
integer gnmin;
doublereal small;
integer gpmin;
doublereal third;
static doublereal lrmin, lrmax;
doublereal sixth;
logical lieee1;
integer ngnmin, ngpmin;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
/* be a reliable guide to the way in which the machine performs */
/* its arithmetic. */
/* EPS (output) DOUBLE PRECISION */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) DOUBLE PRECISION */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value */
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) DOUBLE PRECISION */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
zero = 0.;
one = 1.;
two = 2.;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function DLAMC3 to ensure */
/* that relevant values are stored and not held in registers, or */
/* are not affected by optimizers. */
/* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
dlamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (doublereal) lbeta;
i__1 = -lt;
a = pow_di(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct EPS. */
b = two / 3;
half = one / 2;
d__1 = -half;
sixth = dlamc3_(&b, &d__1);
third = dlamc3_(&sixth, &sixth);
d__1 = -half;
b = dlamc3_(&third, &d__1);
b = dlamc3_(&b, &sixth);
b = abs(b);
if (b < leps) {
b = leps;
}
leps = 1.;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
d__1 = half * leps;
/* Computing 5th power */
d__3 = two, d__4 = d__3, d__3 *= d__3;
/* Computing 2nd power */
d__5 = leps;
d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
c__ = dlamc3_(&d__1, &d__2);
d__1 = -c__;
c__ = dlamc3_(&half, &d__1);
b = dlamc3_(&half, &c__);
d__1 = -b;
c__ = dlamc3_(&half, &d__1);
b = dlamc3_(&half, &c__);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. This */
/* is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i__ = 1; i__ <= 3; ++i__) {
d__1 = small * rbase;
small = dlamc3_(&d__1, &zero);
/* L20: */
}
a = dlamc3_(&one, &small);
dlamc4_(&ngpmin, &one, &lbeta);
d__1 = -one;
dlamc4_(&ngnmin, &d__1, &lbeta);
dlamc4_(&gpmin, &a, &lbeta);
d__1 = -a;
dlamc4_(&gnmin, &d__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual underflow; */
/* e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual underflow; */
/* e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow; */
/* e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflow; */
/* no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
first = FALSE_;
/* ** */
/* Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
e_wsfe();
}
/* ** */
/* Assume IEEE arithmetic if we found denormalised numbers above, */
/* or if arithmetic seems to round in the IEEE style, determined */
/* in routine DLAMC1. A true IEEE machine should have both things */
/* true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could compute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
/* this computation. */
lrmin = 1.;
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = lrmin * rbase;
lrmin = dlamc3_(&d__1, &zero);
/* L30: */
}
/* Finally, call DLAMC5 to compute EMAX and RMAX. */
dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of DLAMC2 */
} /* dlamc2_ */
/* Subroutine */ int dmout_(integer *lout, integer *m, integer *n, doublereal
*a, integer *lda, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Initialized data */
static char icol[1*3] = "C" "o" "l";
/* Format strings */
static char fmt_9999[] = "(/1x,a,/1x,a)";
static char fmt_9998[] = "(10x,10(4x,3a1,i4,1x))";
static char fmt_9994[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,10d12.3)";
static char fmt_9997[] = "(10x,8(5x,3a1,i4,2x))";
static char fmt_9993[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,8d14.5)";
static char fmt_9996[] = "(10x,6(7x,3a1,i4,4x))";
static char fmt_9992[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,6d18.9)";
static char fmt_9995[] = "(10x,5(9x,3a1,i4,6x))";
static char fmt_9991[] = "(1x,\002 Row\002,i4,\002:\002,1x,1p,5d22.13)";
static char fmt_9990[] = "(1x,\002 \002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, k1, k2, lll;
static char line[80];
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9990, 0 };
/* ... */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Computing MIN */
i__1 = i_len(ifmt, ifmt_len);
lll = min(i__1,80);
i__1 = lll;
for (i__ = 1; i__ <= i__1; ++i__) {
*(unsigned char *)&line[i__ - 1] = '-';
/* L10: */
}
for (i__ = lll + 1; i__ <= 80; ++i__) {
*(unsigned char *)&line[i__ - 1] = ' ';
/* L20: */
}
io___5.ciunit = *lout;
s_wsfe(&io___5);
do_fio(&c__1, ifmt, ifmt_len);
do_fio(&c__1, line, lll);
e_wsfe();
if (*m <= 0 || *n <= 0 || *lda <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 72 COLUMNS FORMAT */
/* ======================================================================= */
if (*idigit < 0) {
ndigit = -(*idigit);
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___9.ciunit = *lout;
s_wsfe(&io___9);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___10.ciunit = *lout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L30: */
}
/* L40: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___12.ciunit = *lout;
s_wsfe(&io___12);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___13.ciunit = *lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L50: */
}
/* L60: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 3) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 2;
k2 = min(i__2,i__3);
io___14.ciunit = *lout;
s_wsfe(&io___14);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___15.ciunit = *lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L70: */
}
/* L80: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___16.ciunit = *lout;
s_wsfe(&io___16);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___17.ciunit = *lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L90: */
}
/* L100: */
}
}
/* ======================================================================= */
/* CODE FOR OUTPUT USING 132 COLUMNS FORMAT */
/* ======================================================================= */
} else {
if (ndigit <= 4) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 10) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 9;
k2 = min(i__2,i__3);
io___18.ciunit = *lout;
s_wsfe(&io___18);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___19.ciunit = *lout;
s_wsfe(&io___19);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L110: */
}
/* L120: */
}
} else if (ndigit <= 6) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 8) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 7;
k2 = min(i__2,i__3);
io___20.ciunit = *lout;
s_wsfe(&io___20);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___21.ciunit = *lout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L130: */
}
/* L140: */
}
} else if (ndigit <= 10) {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 6) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 5;
k2 = min(i__2,i__3);
io___22.ciunit = *lout;
s_wsfe(&io___22);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___23.ciunit = *lout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L150: */
}
/* L160: */
}
} else {
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___24.ciunit = *lout;
s_wsfe(&io___24);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__3, icol, (ftnlen)1);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___25.ciunit = *lout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/* L170: */
}
/* L180: */
}
}
}
io___26.ciunit = *lout;
s_wsfe(&io___26);
e_wsfe();
return 0;
} /* dmout_ */
/* Subroutine */ int cckgsv_(integer *nm, integer *mval, integer *pval,
integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
nmax, complex *a, complex *af, complex *b, complex *bf, complex *u,
complex *v, complex *q, real *alpha, real *beta, complex *r__,
integer *iwork, complex *work, real *rwork, integer *nin, integer *
nout, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 CLATMS in CCKGSV INFO = \002,i5)";
static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
"i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
ldv, imat;
char path[3], type__[1];
integer nrun, modea, modeb, nfail;
char dista[1], distb[1];
integer iinfo;
real 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 /* 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 *);
logical dotype[8];
extern /* Subroutine */ int cgsvts_(integer *, integer *, integer *,
complex *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, complex *, integer *, integer *, complex *,
integer *, real *, real *);
logical firstt;
real result[7];
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCKGSV tests CGGSVD: */
/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
/* Arguments */
/* ========= */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* PVAL (input) INTEGER array, dimension (NP) */
/* The values of the matrix row dimension P. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be tested for each combination */
/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
/* number of matrix types), then all the different types are */
/* generated for testing. If NMATS < NTYPES, another input line */
/* is read to get the numbers of the matrix types to be used. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator. The array */
/* elements should be between 0 and 4095, otherwise they will be */
/* reduced mod 4096, and ISEED(4) must be odd. */
/* On exit, the next seed in the random number sequence after */
/* all the test matrices have been generated. */
/* THRESH (input) 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. */
/* 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) */
/* U (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* V (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* Q (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* ALPHA (workspace) REAL array, dimension (NMAX) */
/* BETA (workspace) REAL array, dimension (NMAX) */
/* R (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* RWORK (workspace) REAL 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 CLATMS returns an error code, the absolute value */
/* of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
/* Parameter adjustments */
--rwork;
--work;
--iwork;
--r__;
--beta;
--alpha;
--q;
--v;
--u;
--bf;
--b;
--af;
--a;
--iseed;
--nval;
--pval;
--mval;
/* Function Body */
s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
*info = 0;
nrun = 0;
nfail = 0;
firstt = TRUE_;
alareq_(path, nmats, dotype, &c__8, nin, nout);
lda = *nmax;
ldb = *nmax;
ldu = *nmax;
ldv = *nmax;
ldq = *nmax;
ldr = *nmax;
lwork = *nmax * *nmax;
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
p = pval[im];
n = nval[im];
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat - 1]) {
goto L20;
}
/* Set up parameters with 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);
/* Generate M by N matrix A */
clatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
work[1], &iinfo);
if (iinfo != 0) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L20;
}
/* Generate P by N matrix B */
clatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
work[1], &iinfo);
if (iinfo != 0) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L20;
}
nt = 6;
cgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
result);
/* Print information about the tests that did not */
/* pass the threshold. */
i__2 = nt;
for (i__ = 1; i__ <= i__2; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && firstt) {
firstt = FALSE_;
alahdg_(nout, path);
}
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L10: */
}
nrun += nt;
L20:
;
}
/* L30: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &c__0);
return 0;
/* End of CCKGSV */
} /* cckgsv_ */
/* Subroutine */ int dprtbs_(char *lab1, char *lab2, integer *ntypes, logical
*dotype, integer *nsizes, integer *nn, integer *nparms, logical *
doline, doublereal *reslts, integer *ldr1, integer *ldr2, integer *
nout, ftnlen lab1_len, ftnlen lab2_len)
{
/* Format strings */
static char fmt_9999[] = "(6x,a4,i6,11i9)";
static char fmt_9998[] = "(3x,a4)";
static char fmt_9997[] = "(3x,i4,4x,1p,12(1x,g8.2))";
static char fmt_9996[] = "(11x,1p,12(1x,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
=======
DPRTBS 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.
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 - DOUBLE PRECISION 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;
--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 *)&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(doublereal));
}
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(doublereal));
}
e_wsfe();
}
}
/* L10: */
}
if (iline > 1 && j < *ntypes) {
io___9.ciunit = *nout;
s_wsle(&io___9);
e_wsle();
}
}
/* L20: */
}
return 0;
/* End of DPRTBS */
} /* dprtbs_ */
/* Subroutine */ int dchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGGBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
doublereal a[400] /* was [20][20] */, b[400] /* was [20][20] */;
integer i__, j, n;
doublereal ain[400] /* was [20][20] */, bin[400] /* was [20][20] */;
integer ihi, ilo;
doublereal eps;
integer knt, info, lmax[5];
doublereal rmax, vmax, work[120];
integer ihiin, ninfo, iloin;
doublereal anorm, bnorm;
extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal lscale[20], rscale[20], lsclin[20], rsclin[20];
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = dlange_("M", &n, &n, a, &c__20, work);
bnorm = dlange_("M", &n, &n, b, &c__20, work);
++knt;
dggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
20 - 21], abs(d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = b[i__ + j * 20 - 21] - bin[i__ + j *
20 - 21], abs(d__1));
vmax = max(d__2,d__3);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKGL */
} /* dchkgl_ */
/* Subroutine */ int dlafts_(char *type__, integer *m, integer *n, integer *
imat, integer *ntests, doublereal *result, integer *iseed, doublereal
*thresh, integer *iounit, integer *ie)
{
/* Format strings */
static char fmt_9999[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9998[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,d10.3)";
static char fmt_9997[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
"i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
",i3,\002 is\002,0p,f8.2)";
static char fmt_9996[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
"i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
",i3,\002 is\002,1p,d10.3)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer k;
extern /* Subroutine */ int dlahd2_(integer *, char *);
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___4 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___5 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK auxiliary test routine (version 3.1.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* April 2009 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAFTS tests the result vector against the threshold value to */
/* see which tests for this matrix type failed to pass the threshold. */
/* Output is to the file given by unit IOUNIT. */
/* Arguments */
/* ========= */
/* TYPE - CHARACTER*3 */
/* On entry, TYPE specifies the matrix type to be used in the */
/* printed messages. */
/* Not modified. */
/* N - INTEGER */
/* On entry, N specifies the order of the test matrix. */
/* Not modified. */
/* IMAT - INTEGER */
/* On entry, IMAT specifies the type of the test matrix. */
/* A listing of the different types is printed by DLAHD2 */
/* to the output file if a test fails to pass the threshold. */
/* Not modified. */
/* NTESTS - INTEGER */
/* On entry, NTESTS is the number of tests performed on the */
/* subroutines in the path given by TYPE. */
/* Not modified. */
/* RESULT - DOUBLE PRECISION array of dimension( NTESTS ) */
/* On entry, RESULT contains the test ratios from the tests */
/* performed in the calling program. */
/* Not modified. */
/* ISEED - INTEGER array of dimension( 4 ) */
/* Contains the random seed that generated the matrix used */
/* for the tests whose ratios are in RESULT. */
/* Not modified. */
/* THRESH - DOUBLE PRECISION */
/* On entry, THRESH specifies the acceptable threshold of the */
/* test ratios. If RESULT( K ) > THRESH, then the K-th test */
/* did not pass the threshold and a message will be printed. */
/* Not modified. */
/* IOUNIT - INTEGER */
/* On entry, IOUNIT specifies the unit number of the file */
/* to which the messages are printed. */
/* Not modified. */
/* IE - INTEGER */
/* On entry, IE contains the number of tests which have */
/* failed to pass the threshold so far. */
/* Updated on exit if any of the ratios in RESULT also fail. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
--result;
/* Function Body */
if (*m == *n) {
/* Output for square matrices: */
i__1 = *ntests;
for (k = 1; k <= i__1; ++k) {
if (result[k] >= *thresh) {
/* If this is the first test to fail, call DLAHD2 */
/* to print a header to the data file. */
if (*ie == 0) {
dlahd2_(iounit, type__);
}
++(*ie);
if (result[k] < 1e4) {
io___2.ciunit = *iounit;
s_wsfe(&io___2);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___3.ciunit = *iounit;
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L10: */
}
} else {
/* Output for rectangular matrices */
i__1 = *ntests;
for (k = 1; k <= i__1; ++k) {
if (result[k] >= *thresh) {
/* If this is the first test to fail, call DLAHD2 */
/* to print a header to the data file. */
if (*ie == 0) {
dlahd2_(iounit, type__);
}
++(*ie);
if (result[k] < 1e4) {
io___4.ciunit = *iounit;
s_wsfe(&io___4);
do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___5.ciunit = *iounit;
s_wsfe(&io___5);
do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L20: */
}
}
return 0;
/* End of DLAFTS */
} /* dlafts_ */
/* DECK DSOSEQ */
/* Subroutine */ int dsoseq_(D_fp fnc, integer *n, doublereal *s, doublereal *
rtolx, doublereal *atolx, doublereal *tolf, integer *iflag, integer *
mxit, integer *ncjs, integer *nsrrc, integer *nsri, integer *iprint,
doublereal *fmax, doublereal *c__, integer *nc, doublereal *b,
doublereal *p, doublereal *temp, doublereal *x, doublereal *y,
doublereal *fac, integer *is)
{
/* Format strings */
static char fmt_210[] = "(\0020RESIDUAL NORM =\002,d9.2,/1x,\002SOLUTION"
" ITERATE (\002,i3,\002)\002,/(1x,5d26.14))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal f, h__;
static integer j, k, l, m, ic, kd, jk, kj, kk;
static doublereal fp;
static integer kn, mm;
static doublereal re;
static integer it, js, ls;
static doublereal hx, yj, fn1, fn2;
static integer km1, np1;
static doublereal yn1, yn2, yn3;
static integer icr, isj, mit;
static doublereal csv;
static integer isv, ksv;
static doublereal uro, yns, fdif, fact, fmin;
static integer item;
static doublereal pmax;
static integer loun;
static doublereal fmxs, test, zero;
static integer itry;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
static doublereal xnorm, ynorm, sruro;
extern /* Subroutine */ int dsossl_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_210, 0 };
/* ***BEGIN PROLOGUE DSOSEQ */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSOS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SOSEQS-S, DSOSEQ-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* DSOSEQ solves a system of N simultaneous nonlinear equations. */
/* See the comments in the interfacing routine DSOS for a more */
/* detailed description of some of the items in the calling list. */
/* ********************************************************************** */
/* -Input- */
/* FNC- Function subprogram which evaluates the equations */
/* N -number of equations */
/* S -Solution vector of initial guesses */
/* RTOLX-Relative error tolerance on solution components */
/* ATOLX-Absolute error tolerance on solution components */
/* TOLF-Residual error tolerance */
/* MXIT-Maximum number of allowable iterations. */
/* NCJS-Maximum number of consecutive iterative steps to perform */
/* using the same triangular Jacobian matrix approximation. */
/* NSRRC-Number of consecutive iterative steps for which the */
/* limiting precision accuracy test must be satisfied */
/* before the routine exits with IFLAG=4. */
/* NSRI-Number of consecutive iterative steps for which the */
/* diverging condition test must be satisfied before */
/* the routine exits with IFLAG=7. */
/* IPRINT-Internal printing parameter. You must set IPRINT=-1 if you */
/* want the intermediate solution iterates and a residual norm */
/* to be printed. */
/* C -Internal work array, dimensioned at least N*(N+1)/2. */
/* NC -Dimension of C array. NC .GE. N*(N+1)/2. */
/* B -Internal work array, dimensioned N. */
/* P -Internal work array, dimensioned N. */
/* TEMP-Internal work array, dimensioned N. */
/* X -Internal work array, dimensioned N. */
/* Y -Internal work array, dimensioned N. */
/* FAC -Internal work array, dimensioned N. */
/* IS -Internal work array, dimensioned N. */
/* -Output- */
/* S -Solution vector */
/* IFLAG-Status indicator flag */
/* MXIT-The actual number of iterations performed */
/* FMAX-Residual norm */
/* C -Upper unit triangular matrix which approximates the */
/* forward triangularization of the full Jacobian matrix. */
/* Stored in a vector with dimension at least N*(N+1)/2. */
/* B -Contains the residuals (function values) divided */
/* by the corresponding components of the P vector */
/* P -Array used to store the partial derivatives. After */
/* each iteration P(K) contains the maximal derivative */
/* occurring in the K-th reduced equation. */
/* TEMP-Array used to store the previous solution iterate. */
/* X -Solution vector. Contains the values achieved on the */
/* last iteration loop upon exit from DSOS. */
/* Y -Array containing the solution increments. */
/* FAC -Array containing factors used in computing numerical */
/* derivatives. */
/* IS -Records the pivotal information (column interchanges) */
/* ********************************************************************** */
/* *** Three machine dependent parameters appear in this subroutine. */
/* *** The smallest positive magnitude, zero, is defined by the function */
/* *** routine D1MACH(1). */
/* *** URO, the computer unit roundoff value, is defined by D1MACH(3) for */
/* *** machines that round or D1MACH(4) for machines that truncate. */
/* *** URO is the smallest positive number such that 1.+URO .GT. 1. */
/* *** The output tape unit number, LOUN, is defined by the function */
/* *** I1MACH(2). */
/* ********************************************************************** */
/* ***SEE ALSO DSOS */
/* ***ROUTINES CALLED D1MACH, DSOSSL, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 801001 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* ***END PROLOGUE DSOSEQ */
/* BEGIN BLOCK PERMITTING ...EXITS TO 430 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 410 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 390 */
/* ***FIRST EXECUTABLE STATEMENT DSOSEQ */
/* Parameter adjustments */
--is;
--fac;
--y;
--x;
--temp;
--p;
--b;
--c__;
--s;
/* Function Body */
uro = d1mach_(&c__4);
loun = i1mach_(&c__2);
zero = d1mach_(&c__1);
re = max(*rtolx,uro);
sruro = sqrt(uro);
*iflag = 0;
np1 = *n + 1;
icr = 0;
ic = 0;
itry = *ncjs;
yn1 = 0.;
yn2 = 0.;
yn3 = 0.;
yns = 0.;
mit = 0;
fn1 = 0.;
fn2 = 0.;
fmxs = 0.;
/* INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND */
/* SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
is[k] = k;
x[k] = s[k];
temp[k] = x[k];
/* L10: */
}
/* ********************************************************* */
/* **** BEGIN PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
i__1 = *mxit;
for (m = 1; m <= i__1; ++m) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 350 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 240 */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
fac[k] = sruro;
/* L20: */
}
L30:
/* BEGIN BLOCK PERMITTING ...EXITS TO 180 */
kn = 1;
*fmax = 0.;
/* ******** BEGIN SUBITERATION LOOP DEFINING */
/* THE LINEARIZATION OF EACH ******** */
/* EQUATION WHICH RESULTS IN THE CONSTRUCTION */
/* OF AN UPPER ******** TRIANGULAR MATRIX */
/* APPROXIMATING THE FORWARD ******** */
/* TRIANGULARIZATION OF THE FULL JACOBIAN */
/* MATRIX */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 160 */
km1 = k - 1;
/* BACK-SOLVE A TRIANGULAR LINEAR */
/* SYSTEM OBTAINING IMPROVED SOLUTION */
/* VALUES FOR K-1 OF THE VARIABLES FROM */
/* THE FIRST K-1 EQUATIONS. THESE */
/* VARIABLES ARE THEN ELIMINATED FROM */
/* THE K-TH EQUATION. */
if (km1 == 0) {
goto L50;
}
dsossl_(&k, n, &km1, &y[1], &c__[1], &b[1], &kn);
i__3 = km1;
for (j = 1; j <= i__3; ++j) {
js = is[j];
x[js] = temp[js] + y[j];
/* L40: */
}
L50:
/* EVALUATE THE K-TH EQUATION AND THE */
/* INTERMEDIATE COMPUTATION FOR THE MAX */
/* NORM OF THE RESIDUAL VECTOR. */
f = (*fnc)(&x[1], &k);
/* Computing MAX */
d__1 = *fmax, d__2 = abs(f);
*fmax = max(d__1,d__2);
/* IF WE WISH TO PERFORM SEVERAL */
/* ITERATIONS USING A FIXED */
/* FACTORIZATION OF AN APPROXIMATE */
/* JACOBIAN,WE NEED ONLY UPDATE THE */
/* CONSTANT VECTOR. */
/* ...EXIT */
if (itry < *ncjs) {
goto L160;
}
it = 0;
/* COMPUTE PARTIAL DERIVATIVES THAT ARE */
/* REQUIRED IN THE LINEARIZATION OF THE */
/* K-TH REDUCED EQUATION */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
item = is[j];
hx = x[item];
h__ = fac[item] * hx;
if (abs(h__) <= zero) {
h__ = fac[item];
}
x[item] = hx + h__;
if (km1 == 0) {
goto L70;
}
y[j] = h__;
dsossl_(&k, n, &j, &y[1], &c__[1], &b[1], &kn);
i__4 = km1;
for (l = 1; l <= i__4; ++l) {
ls = is[l];
x[ls] = temp[ls] + y[l];
/* L60: */
}
L70:
fp = (*fnc)(&x[1], &k);
x[item] = hx;
fdif = fp - f;
if (abs(fdif) > uro * abs(f)) {
goto L80;
}
fdif = 0.;
++it;
L80:
p[j] = fdif / h__;
/* L90: */
}
if (it <= *n - k) {
goto L110;
}
/* ALL COMPUTED PARTIAL DERIVATIVES */
/* OF THE K-TH EQUATION ARE */
/* EFFECTIVELY ZERO.TRY LARGER */
/* PERTURBATIONS OF THE INDEPENDENT */
/* VARIABLES. */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
isj = is[j];
fact = fac[isj] * 100.;
/* ..............................EXIT */
if (fact > 1e10) {
goto L390;
}
fac[isj] = fact;
/* L100: */
}
/* ............EXIT */
goto L180;
L110:
/* ...EXIT */
if (k == *n) {
goto L160;
}
/* ACHIEVE A PIVOTING EFFECT BY */
/* CHOOSING THE MAXIMAL DERIVATIVE */
/* ELEMENT */
pmax = 0.;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
test = (d__1 = p[j], abs(d__1));
if (test <= pmax) {
goto L120;
}
pmax = test;
isv = j;
L120:
/* L130: */
;
}
/* ........................EXIT */
if (pmax == 0.) {
goto L390;
}
/* SET UP THE COEFFICIENTS FOR THE K-TH */
/* ROW OF THE TRIANGULAR LINEAR SYSTEM */
/* AND SAVE THE PARTIAL DERIVATIVE OF */
/* LARGEST MAGNITUDE */
pmax = p[isv];
kk = kn;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
if (j != isv) {
c__[kk] = -p[j] / pmax;
}
++kk;
/* L140: */
}
p[k] = pmax;
/* ...EXIT */
if (isv == k) {
goto L160;
}
/* INTERCHANGE THE TWO COLUMNS OF C */
/* DETERMINED BY THE PIVOTAL STRATEGY */
ksv = is[k];
is[k] = is[isv];
is[isv] = ksv;
kd = isv - k;
kj = k;
i__3 = k;
for (j = 1; j <= i__3; ++j) {
csv = c__[kj];
jk = kj + kd;
c__[kj] = c__[jk];
c__[jk] = csv;
kj = kj + *n - j;
/* L150: */
}
L160:
kn = kn + np1 - k;
/* STORE THE COMPONENTS FOR THE CONSTANT */
/* VECTOR */
b[k] = -f / p[k];
/* L170: */
}
/* ......EXIT */
goto L190;
L180:
goto L30;
L190:
/* ******** */
/* ******** END OF LOOP CREATING THE TRIANGULAR */
/* LINEARIZATION MATRIX */
/* ******** */
/* SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW */
/* SOLUTION APPROXIMATION AND OBTAIN THE SOLUTION */
/* INCREMENT NORM. */
--kn;
y[*n] = b[*n];
if (*n > 1) {
dsossl_(n, n, n, &y[1], &c__[1], &b[1], &kn);
}
xnorm = 0.;
ynorm = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
yj = y[j];
/* Computing MAX */
d__1 = ynorm, d__2 = abs(yj);
ynorm = max(d__1,d__2);
js = is[j];
x[js] = temp[js] + yj;
/* Computing MAX */
d__2 = xnorm, d__3 = (d__1 = x[js], abs(d__1));
xnorm = max(d__2,d__3);
/* L200: */
}
/* PRINT INTERMEDIATE SOLUTION ITERATES AND */
/* RESIDUAL NORM IF DESIRED */
if (*iprint != -1) {
goto L220;
}
mm = m - 1;
io___48.ciunit = loun;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&(*fmax), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&mm, (ftnlen)sizeof(integer));
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&x[j], (ftnlen)sizeof(doublereal));
}
e_wsfe();
L220:
/* TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE */
/* AND/OR ABSOLUTE ERROR COMPARISON ON SUCCESSIVE */
/* APPROXIMATIONS OF EACH SOLUTION VARIABLE) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
js = is[j];
/* ......EXIT */
if ((d__2 = y[j], abs(d__2)) > re * (d__1 = x[js], abs(d__1)) + *
atolx) {
goto L240;
}
/* L230: */
}
if (*fmax <= fmxs) {
*iflag = 1;
}
L240:
/* TEST FOR CONVERGENCE TO A SOLUTION BASED ON */
/* RESIDUALS */
if (*fmax <= *tolf) {
*iflag += 2;
}
/* ............EXIT */
if (*iflag > 0) {
goto L410;
}
if (m > 1) {
goto L250;
}
fmin = *fmax;
goto L330;
L250:
/* BEGIN BLOCK PERMITTING ...EXITS TO 320 */
/* SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. */
if (*fmax >= fmin) {
goto L270;
}
mit = m + 1;
yn1 = ynorm;
yn2 = yns;
fn1 = fmxs;
fmin = *fmax;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
s[j] = x[j];
/* L260: */
}
ic = 0;
L270:
/* TEST FOR LIMITING PRECISION CONVERGENCE. VERY */
/* SLOWLY CONVERGENT PROBLEMS MAY ALSO BE */
/* DETECTED. */
if (ynorm > sruro * xnorm) {
goto L290;
}
if (*fmax < fmxs * .2 || *fmax > fmxs * 5.) {
goto L290;
}
if (ynorm < yns * .2 || ynorm > yns * 5.) {
goto L290;
}
++icr;
if (icr >= *nsrrc) {
goto L280;
}
ic = 0;
/* .........EXIT */
goto L320;
L280:
*iflag = 4;
*fmax = fmin;
/* ........................EXIT */
goto L430;
L290:
icr = 0;
/* TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. */
if (ynorm > yns * 2. || *fmax > fmxs * 2.) {
goto L300;
}
ic = 0;
goto L310;
L300:
++ic;
/* ......EXIT */
if (ic < *nsri) {
goto L320;
}
*iflag = 7;
/* .....................EXIT */
goto L410;
L310:
L320:
L330:
/* CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD */
/* JACOBIAN FACTORIZATION */
--itry;
if (itry == 0) {
goto L340;
}
if (ynorm * 20. > xnorm) {
goto L340;
}
if (ynorm > yns * 2.) {
goto L340;
}
/* ......EXIT */
if (*fmax < fmxs * 2.) {
goto L350;
}
L340:
itry = *ncjs;
L350:
/* SAVE THE CURRENT SOLUTION APPROXIMATION AND THE */
/* RESIDUAL AND SOLUTION INCREMENT NORMS FOR USE IN THE */
/* NEXT ITERATION. */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
temp[j] = x[j];
/* L360: */
}
if (m != mit) {
goto L370;
}
fn2 = *fmax;
yn3 = ynorm;
L370:
fmxs = *fmax;
yns = ynorm;
/* L380: */
}
/* ********************************************************* */
/* **** END OF PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
/* TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. */
m = *mxit;
*iflag = 5;
if (yn1 > yn2 * 10. || yn3 > yn1 * 10.) {
*iflag = 6;
}
if (fn1 > fmin * 5. || fn2 > fmin * 5.) {
*iflag = 6;
}
if (*fmax > fmin * 5.) {
*iflag = 6;
}
/* ......EXIT */
goto L410;
L390:
/* A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. */
*iflag = 8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = temp[j];
/* L400: */
}
/* ......EXIT */
goto L430;
L410:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = x[j];
/* L420: */
}
L430:
*mxit = m;
return 0;
} /* dsoseq_ */
int/* Main program */ MAIN__()
{
/* Format strings */
static char fmt_800[] = "(//,\002 ERROR CODE =\002,i3,/)";
static char fmt_810[] = "(10x,\002CURRENT SOLUTION IS \002,/14x,\002I\
\002,11x,\002X(I)\002)";
static char fmt_820[] = "(10x,i5,2x,1pd22.15)";
/* System generated locals */
integer i__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe();
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int sfun_(integer*, doublereal *, doublereal *, doublereal *);
doublereal xtol, f, g[50];
integer i__, n;
doublereal w[700], x[50];
integer maxit, lw;
doublereal accrcy, up[50];
extern /* Subroutine */ int lmqnbc_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, U_fp,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *)
;
integer maxfun, ierror, msglvl, ipivot[50];
doublereal stepmx, eta, low[50];
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, fmt_800, 0 };
static cilist io___20 = { 0, 6, 0, fmt_810, 0 };
static cilist io___21 = { 0, 6, 0, fmt_820, 0 };
/* SET UP FUNCTION AND VARIABLE INFORMATION */
/* N - NUMBER OF VARIABLES */
/* X - INITIAL ESTIMATE OF THE SOLUTION */
/* LOW - LOWER BOUNDS */
/* UP - UPPER BOUNDS */
/* F - ROUGH ESTIMATE OF FUNCTION VALUE AT SOLUTION */
/* LW - DECLARED LENGTH OF THE ARRAY W */
n = 10;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__ - 1] = i__ / (real) (n + 1);
low[i__ - 1] = 0.;
up[i__ - 1] = 6.;
/* L10: */
}
f = 1.;
lw = 700;
/* SET UP CUSTOMIZING PARAMETERS */
/* ETA - SEVERITY OF THE LINESEARCH */
/* MAXFUN - MAXIMUM ALLOWABLE NUMBER OF FUNCTION EVALUATIONS */
/* XTOL - DESIRED ACCURACY FOR THE SOLUTION X* */
/* STEPMX - MAXIMUM ALLOWABLE STEP IN THE LINESEARCH */
/* ACCRCY - ACCURACY OF COMPUTED FUNCTION VALUES */
/* MSGLVL - DETERMINES QUANTITY OF PRINTED OUTPUT */
/* 0 = NONE, 1 = ONE LINE PER MAJOR ITERATION. */
/* MAXIT - MAXIMUM NUMBER OF INNER ITERATIONS PER STEP */
maxit = n / 2;
maxfun = n * 150;
eta = .25;
stepmx = 10.;
accrcy = 1e-15;
xtol = sqrt(accrcy);
msglvl = 1;
/* MINIMIZE THE FUNCTION */
lmqnbc_(&ierror, &n, x, &f, g, w, &lw, (U_fp)sfun_, low, up, ipivot, &
msglvl, &maxit, &maxfun, &eta, &stepmx, &accrcy, &xtol);
/* PRINT THE RESULTS */
if (ierror != 0) {
s_wsfe(&io___19);
do_fio(&c__1, (char *)&ierror, (ftnlen)sizeof(integer));
e_wsfe();
}
if (msglvl >= 1) {
s_wsfe(&io___20);
e_wsfe();
}
if (msglvl >= 1) {
s_wsfe(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&x[i__ - 1], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int serred_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error ex\002,\002its ***\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 */
real a[16] /* was [4][4] */;
logical b[4];
integer i__, j;
real s[4], u[16] /* was [4][4] */, w[16];
char c2[2];
real r1[4], r2[4];
integer iw[8];
real wi[4];
integer nt;
real vl[16] /* was [4][4] */, vr[16] /* was [4][4] */, wr[4], vt[
16] /* was [4][4] */;
integer ihi, ilo, info, sdim;
real abnrm;
extern /* Subroutine */ int sgees_(char *, char *, L_fp, integer *, real *
, integer *, integer *, real *, real *, real *, integer *, real *,
integer *, logical *, integer *), sgeev_(char *,
char *, integer *, real *, integer *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sgesdd_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *, real *,
integer *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), sgesvd_(char *, char *, integer *, integer
*, real *, integer *, real *, real *, integer *, real *, integer *
, real *, integer *, integer *);
extern logical sslect_();
extern /* Subroutine */ int sgeesx_(char *, char *, L_fp, char *, integer
*, real *, integer *, integer *, real *, real *, real *, integer *
, real *, real *, real *, integer *, integer *, integer *,
logical *, integer *), sgeevx_(char *,
char *, char *, char *, integer *, real *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, real *, real *, real *, real *, real *, integer *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___25 = { 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 */
/* ======= */
/* SERRED tests the error exits for the eigenvalue driver routines for */
/* REAL matrices: */
/* PATH driver description */
/* ---- ------ ----------- */
/* SEV SGEEV find eigenvalues/eigenvectors for nonsymmetric A */
/* SES SGEES find eigenvalues/Schur form for nonsymmetric A */
/* SVX SGEEVX SGEEV + balancing and condition estimation */
/* SSX SGEESX SGEES + balancing and condition estimation */
/* SBD SGESVD compute SVD of an M-by-N matrix A */
/* SGESDD compute SVD of an M-by-N matrix A (by divide and */
/* conquer) */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. 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);
/* Initialize A */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (i__ << 2) - 5] = 1.f;
/* L30: */
}
infoc_1.ok = TRUE_;
nt = 0;
if (lsamen_(&c__2, c2, "EV")) {
/* Test SGEEV */
s_copy(srnamc_1.srnamt, "SGEEV ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__6, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__3, &info);
chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "ES")) {
/* Test SGEES */
s_copy(srnamc_1.srnamt, "SGEES ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgees_("X", "N", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgees_("N", "X", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgees_("N", "S", (L_fp)sslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sgees_("N", "S", (L_fp)sslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgees_("V", "S", (L_fp)sslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgees_("N", "S", (L_fp)sslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__2, b, &info);
chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
} else if (lsamen_(&c__2, c2, "VX")) {
/* Test SGEEVX */
s_copy(srnamc_1.srnamt, "SGEEVX", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
sgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 11;
} else if (lsamen_(&c__2, c2, "SX")) {
/* Test SGEESX */
s_copy(srnamc_1.srnamt, "SGEESX", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeesx_("X", "N", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeesx_("N", "X", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeesx_("N", "N", (L_fp)sslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sgeesx_("V", "N", (L_fp)sslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
sgeesx_("N", "N", (L_fp)sslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "BD")) {
/* Test SGESVD */
s_copy(srnamc_1.srnamt, "SGESVD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test SGESDD */
s_copy(srnamc_1.srnamt, "SGESDD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
}
/* Print a summary line. */
if (! lsamen_(&c__2, c2, "BD")) {
if (infoc_1.ok) {
io___24.ciunit = infoc_1.nout;
s_wsfe(&io___24);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___25.ciunit = infoc_1.nout;
s_wsfe(&io___25);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
}
return 0;
/* End of SERRED */
} /* serred_ */
/* Subroutine */ int zchksy_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
doublecomplex *x, doublecomplex *xact, doublecomplex *work,
doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ioff, mode, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer n, nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static integer iuplo, izero, i1, i2, nerrs, lwork;
extern /* Subroutine */ int zpot05_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int zsyt01_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zsyt02_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zsyt03_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *), zlatb4_(char *,
integer *, integer *, integer *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum;
static logical trfcon;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublereal result[8];
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zlatsy_(char *, integer *, doublecomplex *,
integer *, integer *), zerrsy_(char *, integer *),
zsyrfs_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *), zsytrf_(char *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *
, integer *, integer *), zsytri_(char *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *);
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
ZCHKSY tests ZSYTRF, -TRI, -TRS, -RFS, and -CON.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NBVAL)
The values of the blocksize NB.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(2,NSMAX))
RWORK (workspace) DOUBLE PRECISION array,
dimension (NMAX+2*NSMAX)
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrsy_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (imat != 11) {
/* Set up parameters with ZLATB4 and generate a test
matrix with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "N", &a[1], &lda, &work[
1], &info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of
the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
if (iuplo == 1) {
/* Set the first IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* Use a special block diagonal matrix to test alternate
code for the 2 x 2 blocks. */
zlatsy_(uplo, &n, &a[1], &lda, iseed);
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*D*L' or U*D*U' factorization of the
matrix. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
lwork = max(2,nb) * lda;
s_copy(srnamc_1.srnamt, "ZSYTRF", (ftnlen)6, (ftnlen)6);
zsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
lwork, &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from ZSYTRF. */
if (info != k) {
alaerh_(path, "ZSYTRF", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1
Reconstruct matrix from factors and compute residual. */
zsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
&ainv[1], &lda, &rwork[1], result);
nt = 1;
/* + TEST 2
Form the inverse and compute the residual. */
if (inb == 1 && ! trfcon) {
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "ZSYTRI", (ftnlen)6, (ftnlen)
6);
zsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
/* Check error code from ZSYTRI. */
if (info != 0) {
alaerh_(path, "ZSYTRI", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
zsyt03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
1], &lda, &rwork[1], &rcondc, &result[1]);
nt = 2;
}
/* Print information about the tests that did not pass
the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
/* Skip the other tests if this is not the first block
size. */
if (inb > 1) {
goto L150;
}
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.;
goto L140;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZSYTRS", (ftnlen)6, (ftnlen)
6);
zsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
x[1], &lda, &info);
/* Check error code from ZSYTRS. */
if (info != 0) {
alaerh_(path, "ZSYTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
zsyt02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4
Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7
Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZSYRFS", (ftnlen)6, (ftnlen)
6);
zsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
1) + 1], &info);
/* Check error code from ZSYRFS. */
if (info != 0) {
alaerh_(path, "ZSYRFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass
the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8
Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = zlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "ZSYCON", (ftnlen)6, (ftnlen)6);
zsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
rcond, &work[1], &info);
/* Check error code from ZSYCON. */
if (info != 0) {
alaerh_(path, "ZSYCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKSY */
} /* zchksy_ */
/* ========================IDENTIFICATION DIVISION================================ */
/* Subroutine */ int check_(void)
{
/* Format strings */
static char fmt_200[] = "(7(e13.5,\002 \002))";
/* System generated locals */
olist o__1;
cllist cl__1;
/* Builtin functions */
integer f_open(olist *), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void), f_clos(cllist *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 3, 0, fmt_200, 0 };
/* ----------REMARKS. */
/* This is an interface subroutine, */
/* a flexible module which allows user to manipulate physical quantities */
/* of interest at certain key points during the computer run. */
/* Included within this subroutine is a roster of all global variables */
/* and their respective COMMON areas. */
/* Current instructions accumulate abundances of deuterium, helium-3, */
/* helium-4, and lithium-7 for eventual plotting, taking into account */
/* the contribution of beryllium-7 to lithium-7 and tritium to helium-3. */
/* ----------PARAMETERS. */
/* Number of nuclear reactions. */
/* Number of variables to be evolved. */
/* Number of nuclides in calculation. */
/* ----------COMMON AREAS. */
/* Maximum # of lines to be printed. */
/* Reaction parameter */
/* Reaction parameter */
/* Reaction rates. */
/* Evolution paramete */
/* Evolution paramete */
/* Evolution paramete */
/* Default comp param */
/* Computation parame */
/* Default model para */
/* Model parameters. */
/* Default variationl */
/* Variational parame */
/* Time variables. */
/* Dynamic variables. */
/* Energy densities. */
/* Linear eqn coeffi */
/* Nuclide data. */
/* Eval function bl */
/* Eval function bm(z */
/* Eval function bn(z */
/* Coefficients K. */
/* Flags,counters. */
/* Computation locati */
/* Output data. */
/* Neutrino parameter */
/* Run options. */
/* ==========================DECLARATION DIVISION================================= */
/* ----------REACTION PARAMETER VALUES. */
/* Output option. */
/* ----------REACTION PARAMETER NAMES. */
/* Reaction parameters. */
/* Reaction type code (1-11). */
/* Incoming nuclide type (1-26). */
/* Incoming light nuclide type (1-6). */
/* Outgoing light nuclide type (1-6). */
/* Outgoing nuclide type (1-26). */
/* Reverse reaction coefficient. */
/* ----------REACTION RATES. */
/* Energy released in reaction (in 10** */
/* Forward reaction rate coefficients. */
/* ----------EVOLUTION PARAMETERS. */
/* Reverse reaction rate coefficients. */
/* Temperature of photons (units of 10* */
/* Defined by hv = M(atomic)n(baryon)/t */
/* Chemical potential of electron. */
/* ----------EVOLUTION PARAMETERS (DERIVATIVES). */
/* Relative number abundances. */
/* Change in temperature. */
/* Change in hv. */
/* Change in chemical potential. */
/* ----------EVOLUTION PARAMETERS (ORIGINAL VALUES). */
/* Change in relative number abundances */
/* ----------DEFAULT COMPUTATION PARAMETERS. */
/* Rel # abundances at end of 1st R-K l */
/* Default cy. */
/* Default ct. */
/* Default t9i. */
/* Default t9f. */
/* Default ytmin. */
/* ----------COMPUTATION PARAMETERS. */
/* Default accumulation increment. */
/* Time step limiting constant on abund */
/* Time step limiting constant on tempe */
/* Initial temperature (in 10**9 K). */
/* Final temperature (in 10**9 K). */
/* Smallest abundances allowed. */
/* ----------DEFAULT MODEL PARAMETERS. */
/* Accumulation increment. */
/* Default c. */
/* Default cosmological constant. */
/* ----------EARLY UNIVERSE MODEL PARAMETERS. */
/* Default neutrino degeneracy paramete */
/* Gravitational constant. */
/* Neutron lifetime (sec). */
/* Number of neutrino species. */
/* c(1) is variation of gravitational c */
/* c(2) is neutron half-life (min). */
/* c(3) is number of neutrino species. */
/* Cosmological constant. */
/* Neutrino degeneracy parameters. */
/* xi(1) is e neutrino degeneracy param */
/* xi(2) is m neutrino degeneracy param */
/* xi(3) is t neutrino degeneracy param */
/* ----------DEFAULT VARIATIONAL PARAMETERS. */
/* Fierz parameter */
/* Default initial time step. */
/* ----------VARIATIONAL PARAMETERS. */
/* Default baryon-to-photon ratio. */
/* Initial time step. */
/* ----------TIME VARIABLES. */
/* Baryon-to-photon ratio. */
/* Time. */
/* Time step. */
/* ----------DYNAMIC VARIABLES. */
/* (1/t9)*d(t9)/d(t). */
/* Thermodynamic variables (energy dens */
/* ----------ENERGY DENSITIES. */
/* Expansion rate of the universe. */
/* Initial electron neutrino energy den */
/* Initial baryon energy density. */
/* Baryon energy density. */
/* ----------MATRIX COEFFICIENTS FOR LINEAR EQUATION. */
/* Baryon energy density (ratio to init */
/* Relates y(t+dt) to y(t). */
/* Contains y0 in inverse order. */
/* ----------NUCLIDE DATA. */
/* yy in reverse order. */
/* Atomic number of nuclide. */
/* Charge of nuclide. */
/* ----------EVALUATION OF FUNCTIONS bl,bm,bn. */
/* Mass excess of nuclide. */
/* Evaluation of function bl(z). */
/* Evaluation of function bm(z). */
/* ----------EVALUATION OF MODIFIED BESSEL FUNCTIONS. */
/* Evaluation of function bn(z). */
/* ----------FLAGS AND COUNTERS. */
/* Values k0(r),k1(r),k2(r),k3(r),k4(r) */
/* Indicates if output buffer printed. */
/* # total iterations for particular mo */
/* # iterations after outputing a line. */
/* # times accumulated in output buffer */
/* ----------COMPUTATION LOCATION. */
/* Indicates if gaussian elimination fa */
/* ----------OUTPUT ARRAYS. */
/* Time check. */
/* Nuclide mass fractions. */
/* Thermodynamic variables. */
/* Temperature (in units of 10**9 K). */
/* Time. */
/* Time step. */
/* Baryon to photon ratio. */
/* ----------NEUTRINO PARAMETERS. */
/* Expansion rate. */
/* Temperature (in units of MeV). */
/* Neutrino temperature (in units of Me */
/* Neutrino temperature. */
/* Normalizing constant. */
/* Neutrino energy density. */
/* ----------RUN OPTION. */
/* Type of neutrino. */
/* Run network size. */
/* Number of nuclides in computation. */
/* ----------OUTPUT FILE STATUS. */
/* Number of reactions in computation. */
/* Number of output requests. */
/* ===========================PROCEDURE DIVISION================================== */
/* 10--------OPEN FILE------------------------------------------------------------ */
/* Indicates if output file used. */
if (checkcb_1.itime == 1) {
/* Beginning of program. */
o__1.oerr = 0;
o__1.ounit = 3;
o__1.ofnmlen = 10;
o__1.ofnm = "newint.dat";
o__1.orl = 0;
o__1.osta = "new";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
}
/* 20--------WRITE INTO FILE------------------------------------------------------ */
if (checkcb_1.itime == 8) {
/* Right after a run. */
outdat_1.xout[flags_1.it + 279] += outdat_1.xout[flags_1.it + 319];
/* Add beryllium to lithium. */
outdat_1.xout[flags_1.it + 159] += outdat_1.xout[flags_1.it + 119];
/* Add tritium to helium-3. */
outdat_1.xout[flags_1.it + 199] += -3e-4f;
/* my correction for fitted rates+coarse steps */
s_wsfe(&io___1);
do_fio(&c__1, (char *)&modpr_1.c__[2], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&modpr_1.c__[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&outdat_1.etaout[flags_1.it - 1], (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&outdat_1.xout[flags_1.it + 79], (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&outdat_1.xout[flags_1.it + 159], (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&outdat_1.xout[flags_1.it + 199], (ftnlen)
sizeof(real));
do_fio(&c__1, (char *)&outdat_1.xout[flags_1.it + 279], (ftnlen)
sizeof(real));
e_wsfe();
/* Output N_nu, tau_n, eta, H2, He3, He4, an */
}
/* 30--------CLOSE FILE----------------------------------------------------------- */
if (checkcb_1.itime == 10) {
/* End of program. */
cl__1.cerr = 0;
cl__1.cunit = 3;
cl__1.csta = 0;
f_clos(&cl__1);
}
return 0;
/* ----------REFERENCES----------------------------------------------------------- */
/* 1) D.A. Dicus, E.W. Kolb, A.M. Gleeson, E.C.G. Sudarshan, V.L. Teplitz, */
/* M.S. Turner, Phys. Rev. D26 (1982) 2694. (Rad corr, Coulomb Corr) */
/* 2) D. Seckel, Bartol preprint BA-93-16; G. Guyk and M.S. Turner, */
/* FERMILAB preprint FERMILAB-Pub-93/181-A. (Nucleon mass) */
/* 4) S. Dodelson and M.S. Turner, Phys. Rev. D46 (1992) 3372; B. Fields, */
/* S. Dodelson and M.S. Turner, Phys. Rev. D47 (1993) 4309. (Nu heating) */
/* 5) S. Sarkar, Rep. Prog Phys. 59 (1996) 1493 (review) */
} /* check_ */
/* Subroutine */ int zchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *af, doublecomplex *b, doublecomplex *
x, doublecomplex *xact, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
/* Local variables */
integer i__, j, k, m, n;
doublecomplex z__[3];
integer in, kl, ku, ix, lda;
doublereal cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
integer nfail, iseed[4];
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
doublereal rcondc, rcondi;
doublereal rcondo, ainvnm;
logical trfcon;
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* AF (workspace) COMPLEX*16 array, dimension (NMAX*4) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX)+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements whose real and */
/* imaginary parts are from [-1,1]. */
i__3 = n + (m << 1);
zlarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.) {
i__3 = n + (m << 1);
zdscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
if (n > 1) {
a[1].r = z__[2].r, a[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = n - 1 + izero;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
i__3 = izero;
a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n;
a[i__3].r = 0., a[i__3].i = 0.;
if (n > 1) {
z__[2].r = a[1].r, z__[2].i = a[1].i;
a[1].r = 0., a[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
i__3 = (n << 1) - 1;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = n - 1 + i__;
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0., a[i__3].i = 0.;
i__3 = (n << 1) - 1;
a[i__3].r = 0., a[i__3].i = 0.;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "ZGTTRF", (ftnlen)32, (ftnlen)6);
zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from ZGTTRF. */
if (info != izero) {
alaerh_(path, "ZGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = zlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use ZGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "ZGTCON", (ftnlen)32, (ftnlen)6);
zgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
info);
/* Check error code from ZGTCON. */
if (info != 0) {
alaerh_(path, "ZGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
zlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZGTTRS", (ftnlen)32, (ftnlen)6);
zgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from ZGTTRS. */
if (info != 0) {
alaerh_(path, "ZGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
zgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZGTRFS", (ftnlen)32, (ftnlen)6);
zgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
nrhs << 1) + 1], &info);
/* Check error code from ZGTRFS. */
if (info != 0) {
alaerh_(path, "ZGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
zgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass the */
/* threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKGT */
} /* zchkgt_ */
/* Subroutine */ int dchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *h__, doublereal *t1,
doublereal *t2, doublereal *u, integer *ldu, doublereal *z__,
doublereal *uz, doublereal *wr1, doublereal *wi1, doublereal *wr3,
doublereal *wi3, doublereal *evectl, doublereal *evectr, doublereal *
evecty, doublereal *evectx, doublereal *uu, doublereal *tau,
doublereal *work, integer *nwork, integer *iwork, logical *select,
doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 DCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
doublereal ulp, cond;
integer jcol, nmax;
doublereal unfl, ovfl, temp1, temp2;
logical badnn;
extern /* Subroutine */ int dget10_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dget22_(char *, char *, char *, integer *, doublereal *, integer *
, doublereal *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *), dgemm_(char *, char *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
logical match;
integer imode;
doublereal dumma[6];
integer iinfo, nselc;
doublereal conds;
extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
doublereal aninv, anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer nmats, nselr, jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *), dhsein_(char
*, char *, char *, logical *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *,
integer *, integer *);
integer idumma[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlatmr_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublereal *, integer *,
integer *, integer *), dlasum_(char *, integer *, integer *, integer *),
dhseqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublereal *, integer *, doublereal *, integer
*), dorghr_(integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *), dormhr_(char *, char *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
xerbla_(char *, integer *);
doublereal rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* DGEHRD factors A as U H U' , where ' means transpose, */
/* H is hessenberg, and U is an orthogonal matrix. */
/* DORGHR generates the orthogonal matrix U. */
/* DORMHR multiplies a matrix by the orthogonal matrix U. */
/* DHSEQR factors H as Z T Z' , where Z is orthogonal and */
/* T is "quasi-triangular", and the eigenvalue vector W. */
/* DTREVC computes the left and right eigenvector matrices */
/* L and R for T. */
/* DHSEIN computes the left and right eigenvector matrices */
/* Y and X for H, using inverse iteration. */
/* When DCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**T | / ( |A| n ulp ) */
/* (2) | I - UU**T | / ( n ulp ) */
/* (3) | H - Z T Z**T | / ( |H| n ulp ) */
/* (4) | I - ZZ**T | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**T | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**T | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is orthogonal and */
/* T has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is orthogonal and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (12) A matrix of the form U' T U, where U is orthogonal and */
/* T has real or complex conjugate paired eigenvalues randomly */
/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random signs on the diagonal and random */
/* O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has real or complex conjugate paired */
/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
/* O(1) entries in the upper triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, DCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by DGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by DHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by DHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The orthogonal matrix computed by DGEHRD. */
/* Modified. */
/* Z - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The orthogonal matrix computed by DHSEQR. */
/* Modified. */
/* UZ - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* WR1 - DOUBLE PRECISION array, dimension (max(NN)) */
/* WI1 - DOUBLE PRECISION array, dimension (max(NN)) */
/* The real and imaginary parts of the eigenvalues of A, */
/* as computed when Z is computed. */
/* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A. */
/* Modified. */
/* WR3 - DOUBLE PRECISION array, dimension (max(NN)) */
/* WI3 - DOUBLE PRECISION array, dimension (max(NN)) */
/* Like WR1, WI1, these arrays contain the eigenvalues of A, */
/* but those computed when DHSEQR only computes the */
/* eigenvalues, i.e., not the Schur vectors and no more of the */
/* Schur form than is necessary for computing the */
/* eigenvalues. */
/* Modified. */
/* EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The (upper triangular) left eigenvector matrix for the */
/* matrix in T1. For complex conjugate pairs, the real part */
/* is stored in one row and the imaginary part in the next. */
/* Modified. */
/* EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. For complex conjugate pairs, the real part */
/* is stored in one column and the imaginary part in the next. */
/* Modified. */
/* EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The left eigenvector matrix for the */
/* matrix in H. For complex conjugate pairs, the real part */
/* is stored in one row and the imaginary part in the next. */
/* Modified. */
/* EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the */
/* matrix in H. For complex conjugate pairs, the real part */
/* is stored in one column and the imaginary part in the next. */
/* Modified. */
/* UU - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
/* Details of the orthogonal matrix computed by DGEHRD. */
/* Modified. */
/* TAU - DOUBLE PRECISION array, dimension(max(NN)) */
/* Further details of the orthogonal matrix computed by DGEHRD. */
/* Modified. */
/* WORK - DOUBLE PRECISION array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* RESULT - DOUBLE PRECISION array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -28: NWORK too small. */
/* If DLATMR, SLATMS, or SLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then DHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by DLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--wr1;
--wi1;
--wr3;
--wi3;
--tau;
--work;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -28;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (n == 0) {
goto L270;
}
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
if (jcol > 1) {
a[jcol + (jcol - 1) * a_dim1] = 1.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call DGEHRD to compute H and U, do tests. */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
dgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, "DGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
uu[j + 1 + j * uu_dim1] = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
u[i__ + j * u_dim1] = h__[i__ + j * h_dim1];
uu[i__ + j * uu_dim1] = h__[i__ + j * h_dim1];
h__[i__ + j * h_dim1] = 0.;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
dcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
dorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &result[1]);
/* Call DHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (WR3,WI3) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
dhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "DHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L250;
}
}
/* Eigenvalues (WR1,WI1) and Full Schur Form (T2) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
dhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "DHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors */
/* (UZ) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
dlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);
dhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Compute Z = U' UZ */
dgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &result[3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &result[5]);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
dget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__5 = temp1, d__6 = (d__1 = wr1[j], abs(d__1)) + (d__2 = wi1[
j], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 =
wr3[j], abs(d__3)) + (d__4 = wi3[j], abs(d__4));
temp1 = max(d__5,d__6);
/* Computing MAX */
d__3 = temp2, d__4 = (d__1 = wr1[j] - wr3[j], abs(d__1)) + (
d__2 = wr1[j] - wr3[j], abs(d__2));
temp2 = max(d__3,d__4);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */
nselc = 0;
nselr = 0;
j = n;
L140:
if (wi1[j] == 0.) {
/* Computing MAX */
i__3 = n / 4;
if (nselr < max(i__3,1)) {
++nselr;
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
--j;
} else {
/* Computing MAX */
i__3 = n / 4;
if (nselc < max(i__3,1)) {
++nselc;
select[j] = TRUE_;
select[j - 1] = FALSE_;
} else {
select[j] = FALSE_;
select[j - 1] = FALSE_;
}
j += -2;
}
if (j > 0) {
goto L140;
}
dtrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "DTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
dget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
dtrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "DTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
evectl_dim1]) {
match = FALSE_;
goto L180;
}
/* L150: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
evectl_dim1] || evectr[jj + (j + 1) *
evectr_dim1] != evectl[jj + (k + 1) *
evectl_dim1]) {
match = FALSE_;
goto L180;
}
/* L160: */
}
k += 2;
}
/* L170: */
}
L180:
if (! match) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
dtrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "DTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
dget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
dtrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "DTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
evectr_dim1]) {
match = FALSE_;
goto L220;
}
/* L190: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
evectr_dim1] || evectl[jj + (j + 1) *
evectl_dim1] != evectr[jj + (k + 1) *
evectr_dim1]) {
match = FALSE_;
goto L220;
}
/* L200: */
}
k += 2;
}
/* L210: */
}
L220:
if (! match) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call DHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
dhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "DHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
dget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L240: */
}
dhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "DHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
dget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DORMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___65.ciunit = *nounit;
s_wsfe(&io___65);
do_fio(&c__1, "DORMHR(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
dget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call DORMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___66.ciunit = *nounit;
s_wsfe(&io___66);
do_fio(&c__1, "DORMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
dget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L250:
ntestt += ntest;
dlafts_("DHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L260:
;
}
L270:
;
}
/* Summary */
dlasum_("DHS", nounit, &nerrs, &ntestt);
return 0;
/* End of DCHKHS */
} /* dchkhs_ */
/* Subroutine */ int ddrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Local variables */
integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4], nfact;
char equed[1];
doublereal roldc, rcond, scond;
integer nimat;
doublereal anorm;
logical equil;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
logical prefac;
doublereal rcondc;
logical nofact;
char packit[1];
integer iequed;
doublereal cndnum;
doublereal ainvnm;
doublereal result[6];
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVPP tests the driver routines DPPSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
rcondc = 1. / cndnum;
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L120;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dcopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by DPPSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dcopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
dlaqsp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in DGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = dlansp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
dpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
dcopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
dpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
dcopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test DPPSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPPSV ", (ftnlen)32, (
ftnlen)6);
dppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from DPPSV . */
if (info != izero) {
alaerh_(path, "DPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "DPPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test DPPSVX --- */
if (! prefac && npp > 0) {
dlaset_("Full", &npp, &c__1, &c_b60, &c_b60, &
afac[1], &npp);
}
dlaset_("Full", &n, nrhs, &c_b60, &c_b60, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
dlaqsp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DPPSVX. */
s_copy(srnamc_1.srnamt, "DPPSVX", (ftnlen)32, (ftnlen)
6);
dppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &iwork[
1], &info);
/* Check the error code from DPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from DPPSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "DPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "DPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVPP */
} /* ddrvpp_ */
/* ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc */
/* Subroutine */ int dcgdrv_(U_fp matvec, U_fp pcondl, U_fp pcondr,
doublereal *a, integer *ia, doublereal *x, doublereal *b, integer *n,
doublereal *q, integer *iq, doublereal *p, integer *ip, integer *
iparam, doublereal *rparam, integer *iwork, doublereal *rwork,
integer *ierror)
{
/* Format strings */
static char fmt_100[] = "(\002 USING CGCODE: ICG=\002,i10)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
extern /* Subroutine */ int dcg_(U_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
static integer icg, nce;
extern /* Subroutine */ int dcr_(U_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dpcg_(U_fp, U_fp,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
static integer kmax;
extern /* Subroutine */ int dcgne_(U_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dcgnr_(U_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dppcg_(U_fp, U_fp, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dpcgca_(
U_fp, U_fp, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
), dpcgne_(U_fp, U_fp, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dcrind_(
U_fp, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
static integer icycle;
extern /* Subroutine */ int dpcgnr_(U_fp, U_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *)
;
static integer iolevl, iounit;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_100, 0 };
/* ***BEGIN PROLOGUE DCGDRV */
/* ***DATE WRITTEN 860115 (YYMMDD) */
/* ***REVISION DATE 900210 (YYMMDD) */
/* ***CATEGORY NO. D2A4,D2B4 */
/* ***KEYWORDS LINEAR SYSTEM,SPARSE,ITERATIVE,CONJUGATE GRADIENTS */
/* ***AUTHOR ASHBY,STEVEN F., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* ***AUTHOR HOLST,MICHAEL J., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* MANTEUFFEL,THOMAS A., (LANL) */
/* LOS ALAMOS NATIONAL LABORATORY */
/* MAIL STOP B265 */
/* LOS ALAMOS, NM 87545 */
/* ***PURPOSE THIS SUBROUTINE IS AN INTERFACE TO CGCODE, A PACKAGE OF */
/* PRECONDITIONED CONJUGATE GRADIENT CODES. THESE CODES */
/* WILL SOLVE BOTH SYMMETRIC AND NONSYMMETRIC LINEAR SYSTEMS, */
/* WITH OR WITHOUT PRECONDITIONING. PRECONDITIONING INCLUDES */
/* USER SUPPLIED PRECONDITIONERS AND/OR OR AUTOMATIC ADAPTIVE */
/* POLYNOMIAL PRECONDITIONING. SEE THE FLAGS ICG=IPARAM(13) */
/* AND IPCOND=IPARAM(7) FOR DETAILS; ALSO SEE THE INDIVIDUAL */
/* SUBROUTINES' PROLOGUES. THE ARGUMENT LIST OF THIS */
/* INTERFACE SUBROUTINE CONFORMS TO THE PROPOSED STANDARD FOR */
/* ITERATIVE LINEAR SOLVERS (SEE THE BIBLIOGRAPHY FOR MORE */
/* INFORMATION.) */
/* ***DEDCRIPTION */
/* --- ON ENTRY --- */
/* MATVEC EXTERNAL SUBROUTINE MATVEC(JOB,A,IA,W,X,Y,N) */
/* THE USER MUST PROVIDE A SUBROUTINE HAVING THE SPECIFED */
/* PARAMETER LIST. THE SUBROUTINE MUST RETURN THE PRODUCT */
/* (OR A RELATED COMPUTATION; SEE BELOW) Y=A*X, WHERE A IS */
/* THE COEFFICIENT MATRIX OF THE LINEAR SYSTEM. THE MATRIX */
/* A IS REPRESENTED BY THE WORK ARRAYS A AND IA, DEDCRIBED */
/* BELOW. THE INTEGER PARAMETER JOB SPECIFIES THE PRODUCT */
/* TO BE COMPUTED: */
/* JOB=0 Y=A*X */
/* JOB=1 Y=AT*X */
/* JOB=2 Y=W - A*X */
/* JOB=3 Y=W - AT*X. */
/* IN THE ABOVE, AT DENOTES A-TRANSPOSE. NOTE THAT */
/* ONLY THE VALUES OF JOB=0,1 ARE REQUIRED FOR CGCODE. */
/* ALL OF THE ROUTINES IN CGCODE REQUIRE JOB=0; THE */
/* ROUTINES DCGNR, DCGNE, DPCGNR, AND DPCGNE ALSO REQUIRE */
/* THE VALUE OF JOB=1. (THE VALUES OF JOB=2,3 ARE NOT */
/* REQUIRED BY ANY OF THE ROUTINES IN CGCODE, BUT MAY BE */
/* REQUIRED BY OTHER ITERATIVE PACKAGES CONFORMING TO THE */
/* PROPOSED ITERATIVE STANDARD.) THE PARAMETERS W,X,Y ARE */
/* ALL VECTORS OF LENGTH N. THE ONLY PARAMETER THAT MAY BE */
/* CHANGED INSIDE THE ROUTINE IS Y. MATVEC WILL USUALLY */
/* SERVE AS AN INTERFACE TO THE USER'S OWN MATRIX-VECTOR */
/* MULTIPLY SUBROUTINE. */
/* NOTE: MATVEC MUST BE DECLARED IN AN EXTERNAL STATEMENT */
/* IN THE CALLING PROGRAM. */
/* PCONDL EXTERNAL SUBROUTINE PCONDL(JOB,Q,IQ,W,X,Y,N) */
/* PCONDL IMPLEMENTS A USER SUPPLIED LEFT-PRECONDITIONER. */
/* IF PRECONDITIONING IS SPECIFIED BY THE USER, THEN THE */
/* USER MUST PROVIDE A SUBROUTINE HAVING THE SPECIFED */
/* PARAMETER LIST. THE SUBROUTINE MUST RETURN THE PRODUCT */
/* (OR A RELATED COMPUTATION; SEE BELOW) Y=C*X, WHERE C */
/* IS A PRECONDITIONING MATRIX. THE MATRIX C IS */
/* REPRESENTED BY THE WORK ARRAYS Q AND IQ, DEDCRIBED */
/* BELOW. THE INTEGER PARAMETER JOB SPECIFIES THE PRODUCT */
/* TO BE COMPUTED: */
/* JOB=0 Y=C*X */
/* JOB=1 Y=CT*X */
/* JOB=2 Y=W - C*X */
/* JOB=3 Y=W - CT*X. */
/* IN THE ABOVE, CT DENOTES C-TRANSPOSE. NOTE THAT */
/* ONLY THE VALUES OF JOB=0,1 ARE REQUIRED FOR CGCODE. */
/* THE ROUTINES DPCG, DPCGNR, DPCGNE, DPPCG, AND DPCGCA IN */
/* CGCODE REQUIRE JOB=0; THE ROUTINES DPCGNR AND DPCGNE ALSO */
/* REQUIRE THE VALUE OF JOB=1. (THE VALUES OF JOB=2,3 ARE */
/* NOT REQUIRED BY ANY OF THE ROUTINES IN CGCODE, BUT MAY BE */
/* REQUIRED BY OTHER ITERATIVE PACKAGES CONFORMING TO THE */
/* PROPOSED ITERATIVE STANDARD.) THE PARAMETERS W,X,Y ARE */
/* ALL VECTORS OF LENGTH N. THE ONLY PARAMETER THAT MAY BE */
/* CHANGED INSIDE THE ROUTINE IS Y. PCONDL WILL USUALLY */
/* SERVE AS AN INTERFACE TO THE USER'S OWN PRECONDITIONING */
/* NOTE: PCONDL MUST BE DECLARED IN AN EXTERNAL STATEMENT */
/* IN THE CALLING PROGRAM. IF NO PRE-CONDITIONING IS BEING */
/* DONE, PCONDL IS A DUMMY ARGUMENT. */
/* PCONDR DUMMY ARGUMENT (MANDATED BY PROPOSED STANDARD.) */
/* A DBLE ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S DBLE WORK ARRAY, USUALLY */
/* THE MATRIX A. SINCE A IS ONLY ACCESSED BY CALLS TO SUBR */
/* MATVEC, IT MAY BE A DUMMY ADDRESS. */
/* IA INTEGER ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S INTEGER WORK ARRAY. THIS */
/* USUALLY CONTAINS ADDITIONAL INFORMATION ABOUT A NEEDED BY */
/* MATVEC. SINCE IA IS ONLY ACCESSED BY CALLS TO MATVEC, IT */
/* MAY BE A DUMMY ADDRESS. */
/* X DBLE(N). */
/* THE INITIAL GUESS VECTOR, X0. */
/* (ON EXIT, X IS OVERWRITTEN WITH THE APPROXIMATE SOLUTION */
/* OF A*X=B.) */
/* B DBLE(N). */
/* THE RIGHT-HAND SIDE VECTOR OF THE LINEAR SYSTEM AX=B. */
/* NOTE: B IS CHANGED BY THE SOLVER. */
/* N INTEGER. */
/* THE ORDER OF THE MATRIX A IN THE LINEAR SYSTEM AX=B. */
/* Q DBLE ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S LEFT-PRECONDITIONING ARRAY, */
/* Q. SINCE Q IS ONLY ACCESSED BY CALLS TO PCONDL, IT MAY BE */
/* A DUMMY ADDRESS. IF NO LEFT-PRECONDITIONING IS BEING */
/* DONE, THIS IS A DUMMY ARGUMENT. */
/* IQ INTEGER ARRAY ADDRESS. */
/* THE BASE ADDRESS OF AN INTEGER WORK ARRAY ASSOCIATED WITH */
/* Q. THIS PROVIDES THE USER WITH A WAY OF PASSING INTEGER */
/* INFORMATION ABOUT Q TO PCONDL. SINCE IQ IS ONLY ACCESSED */
/* BY CALLS TO PCONDL, IT MAY BE A DUMMY ADDRESS. IF NO */
/* LEFT-PRECONDITIONING IS BEING DONE, THIS IS A DUMMY */
/* ARGUMENT. */
/* P DUMMY ARGUMENT (MANDATED BY PROPOSED STANDARD.) */
/* IP DUMMY ARGUMENT (MANDATED BY PROPOSED STANDARD.) */
/* IPARAM INTEGER(40). */
/* AN ARRAY OF INTEGER INPUT PARAMETERS: */
/* NOTE: IPARAM(1) THROUGH IPARAM(10) ARE MANDATED BY THE */
/* PROPOSED STANDARD; IPARAM(11) THROUGH IPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* IPARAM(31) THROUGH IPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* IPARAM(1) = NIPAR */
/* LENGTH OF THE IPARAM ARRAY. */
/* IPARAM(2) = NRPAR */
/* LENGTH OF THE RPARAM ARRAY. */
/* IPARAM(3) = NIWK */
/* LENGTH OF THE IWORK ARRAY. */
/* IPARAM(4) = NRWK */
/* LENGTH OF THE RWORK ARRAY. */
/* IPARAM(5) = IOUNIT */
/* IF (IOUNIT > 0) THEN ITERATION INFORMATION (AS */
/* SPECIFIED BY IOLEVL; SEE BELOW) IS SENT TO UNIT=IOUNIT, */
/* WHICH MUST BE OPENED IN THE CALLING PROGRAM. */
/* IF (IOUNIT <= 0) THEN THERE IS NO OUTPUT. */
/* IPARAM(6) = IOLEVL */
/* SPECIFIES THE AMOUNT AND TYPE OF INFORMATION TO BE */
/* OUTPUT IF (IOUNIT > 0): */
/* IOLEVL = 0 OUTPUT ERROR MESSAGES ONLY */
/* IOLEVL = 1 OUTPUT INPUT PARAMETERS AND LEVEL 0 INFO */
/* IOLEVL = 2 OUTPUT STPTST (SEE BELOW) AND LEVEL 1 INFO */
/* IOLEVL = 3 OUTPUT LEVEL 2 INFO AND MORE DETAILS */
/* IPARAM(7) = IPCOND */
/* PRECONDITIONING FLAG, SPECIFIED AS: */
/* IPCOND = 0 NO PRECONDITIONING */
/* IPCOND = 1 LEFT PRECONDITIONING */
/* IPCOND = 2 RIGHT PRECONDITIONING */
/* IPCOND = 3 BOTH LEFT AND RIGHT PRECONDITIONING */
/* NOTE: RIGHT PRECONDITIONING IS A MANDATED OPTION OF THE */
/* PROPOSED STANDARD, BUT NOT IMPLEMENTED IN CGCODE. */
/* IPARAM(8) = ISTOP */
/* STOPPING CRITERION FLAG, INTERPRETED AS: */
/* ISTOP = 0 ||E||/||E0|| <= ERRTOL (DEFAULT) */
/* ISTOP = 1 ||R|| <= ERRTOL */
/* ISTOP = 2 ||R||/||B|| <= ERRTOL */
/* ISTOP = 3 ||C*R|| <= ERRTOL */
/* ISTOP = 4 ||C*R||/||C*B|| <= ERRTOL */
/* WHERE E=ERROR, R=RESIDUAL, B=RIGHT HAND SIDE OF A*X=B, */
/* AND C IS THE PRECONDITIONING MATRIX OR PRECONDITIONING */
/* POLYNOMIAL (OR BOTH.) */
/* NOTE: IF ISTOP=0 IS SELECTED BY THE USER, THEN ERRTOL */
/* IS THE AMOUNT BY WHICH THE INITIAL ERROR IS TO BE */
/* REDUCED. BY ESTIMATING THE CONDITION NUMBER OF THE */
/* ITERATION MATRIX, THE CODE ATTEMPTS TO GUARANTEE THAT */
/* THE FINAL RELATIVE ERROR IS .LE. ERRTOL. SEE THE LONG */
/* DEDCRIPTION BELOW FOR DETAILS. */
/* IPARAM(9) = ITMAX */
/* THE MAXIMUM NUMBER OF ITERATIVE STEPS TO BE TAKEN. */
/* IF SOLVER IS UNABLE TO SATISFY THE STOPPING CRITERION */
/* WITHIN ITMAX ITERATIONS, IT RETURNS TO THE CALLING */
/* PROGRAM WITH IERROR=-1000. */
/* IPARAM(31) = ICYCLE */
/* THE FREQUENCY WITH WHICH A CONDITION NUMBER ESTIMATE IS */
/* COMPUTED; SEE THE LONG DEDCRIPTION BELOW. */
/* IPARAM(32) = NCE */
/* THE MAXIMUM NUMBER OF CONDITION NUMBER ESTIMATES TO BE */
/* COMPUTED. IF NCE = 0 NO ESTIMATES ARE COMPUTED. SEE */
/* THE LONG DEDCRIPTION BELOW. */
/* IPARAM(33) = ICG */
/* A FLAG SPECIFYING THE METHOD TO BE USED. BELOW C IS */
/* THE USER'S PRECONDITIONING MATRIX, CT ITS TRANSPOSE, */
/* AND AT IS THE TRANSPOSE OF A. */
/* ICG=1 : CG : CONJUGATE GRADIENTS ON A, A SPD (CGHS) */
/* ICG=2 : CR : CONJUGATE RESIDUALS ON A, A SPD */
/* ICG=3 : CRIND : CR ON A, A SYMMETRIC */
/* ICG=4 : PCG : PRECONITIONED CG ON A, A AND C SPD */
/* ICG=5 : CGNR : CGHS ON AT*A, A ARBITRARY */
/* ICG=6 : CGNE : CGHS ON A*AT, A ARBITRARY */
/* ICG=7 : PCGNR : CGNR ON A*C, A AND C ARBITRARY */
/* ICG=8 : PCGNE : CGNE ON C*A, A AND C ARBITRARY */
/* ICG=8 : PPCG : POLYNOMIAL PCG ON A, A AND C SPD */
/* ICG=10: PCGCA : CGHS ON C(A)*A, A AND C SPD */
/* IF (1 .LT. ICG) OR (ICG .GT. 10) THEN ICG=1 IS ASSUMED. */
/* IPARAM(34) = NDEG */
/* WHEN USING THE CONJUGATE GRADIENT ROUTINES DPPCG AND */
/* DPCGCA, NDEG SPECIFIES THE DEGREE OF THE PRECONDITIONING */
/* POLYNOMIAL TO BE USED IN THE ADAPTIVE POLYNOMIAL */
/* PRECONDITIONING ROUTINES. */
/* NOTE: KMAX = ICYCLE*NCE IS THE ORDER OF THE LARGEST */
/* ORTHOGONAL SECTION OF C*A USED TO COMPUTE A CONDITION */
/* NUMBER ESTIMATE. THIS ESTIMATE IS ONLY USED IN THE */
/* STOPPING CRITERION. AS SUCH, KMAX SHOULD BE MUCH LESS */
/* THAN N. OTHERWISE THE CODE WILL HAVE EXCESSIVE STORAGE */
/* AND WORK REQUIREMENTS. */
/* RPARAM DBLE(40). */
/* AN ARRAY OF DBLE INPUT PARAMETERS: */
/* NOTE: RPARAM(1) AND RPARAM(2) ARE MANDATED BY THE */
/* PROPOSED STANDARD; RPARAM(3) THROUGH RPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* RPARAM(31) THROUGH RPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* RPARAM(1) = ERRTOL */
/* USER PROVIDED ERROR TOLERANCE; SEE ISTOP ABOVE, AND THE */
/* LONG DEDCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* AN INITIAL ESTIMATE FOR THE COND NUMBER OF THE ITERATION */
/* MATRIX; SEE THE INDIVIDUAL SUBROUTINE'S PROLOGUE. AN */
/* ACCEPTABLE INITIAL VALUE IS 1.0. */
/* RPARAM(32) = AA */
/* INITIAL ESTIMATE OF THE SMALLEST EIGENVALUE OF THE */
/* SYSTEM MATRIX. WHEN USING THE CONJUGATE GRADIENT */
/* ROUTINES DPPCG AND DPCGCA, AA IS USED IN THE ADAPTIVE */
/* POLYNOMIAL PRECONDITIONING ROUTINES FOR FORMING THE */
/* OPTIMAL PRECONDITIONING POLYNOMIAL. */
/* RPARAM(33) = BB */
/* INITIAL ESTIMATE OF THE LARGEST EIGENVALUE OF THE */
/* SYSTEM MATRIX. WHEN USING THE CONJUGATE GRADIENT */
/* ROUTINES DPPCG AND DPCGCA, BB IS USED IN THE ADAPTIVE */
/* POLYNOMIAL PRECONDITIONING ROUTINES FOR FORMING THE */
/* OPTIMAL PRECONDITIONING POLYNOMIAL. */
/* RWORK DBLE(N1+N2). */
/* WORK ARRAY, WHERE N1 AND N2 ARE INTEGERS SUCH THAT: */
/* N1 .GE. 2*N FOR DCG, DPCG, DCGNR, DCGNE. */
/* N1 .GE. 3*N FOR DCR, DPCGNR, DPCGNE. */
/* N1 .GE. 5*N FOR DCRIND */
/* N1 .GE. 6*N FOR DPPCG, DPCGCA. */
/* N2 .GE. 2*ICYCLE*NCE+2 FOR DPPCG, DPCGCA */
/* N2 .GE. 4*ICYCLE*NCE+2 FOR DCG, DCR, DPCG, DCGNR, */
/* DCGNE, DPCGNR, DPCGNE, */
/* DCRIND */
/* THE N2 SPACE IS FOR COMPUTING CONDITION NUMBER ESTIMATES; */
/* THE N1 SPACE IS FOR TEMPORARY VECTORS. TO SAVE STORAGE */
/* AND WORK, ICYCLE*NCE SHOULD BE MUCH LESS THAN N. NOTE */
/* THAT IF NCE = 0, N2 MAY BE SET TO ZERO. */
/* IWORK INTEGER(ICYCLE*NCE) */
/* INTEGER WORK ARRAY FOR COMPUTING COND NUMBER ESTIMATES. */
/* IF NCE = 0, THIS MAY BE A DUMMY ADDRESS. */
/* --- ON RETURN --- */
/* IPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* IPARAM(10) = ITERS */
/* THE NUMBER OF ITERATIONS TAKEN. IF IERROR=0, THEN X_ITERS */
/* SATISFIES THE SPECIFIED STOPPING CRITERION. IF */
/* IERROR=-1000, CGCODE WAS UNABLE TO CONVERGE WITHIN ITMAX */
/* ITERATIONS, AND X_ITERS IS CGCODE'S BEST APPROXIMATION TO */
/* THE SOLUTION OF A*X=B. */
/* RPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* RPARAM(2) = STPTST */
/* FINAL QUANTITY USED IN THE STOPPING CRITERION; SEE ISTOP */
/* ABOVE, AND THE LONG DEDCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* CONDITION NUMBER ESTIMATE; FINAL ESTIMATE USED IN THE */
/* STOPPING CRITERION; SEE ISTOP ABOVE, AND THE LONG */
/* DEDCRIPTION BELOW. */
/* RPARAM(34) = DCRLRS */
/* THE SCALED RELATIVE RESIDUAL USING THE LAST COMPUTED */
/* RESIDUAL. */
/* X THE COMPUTED SOLUTION OF THE LINEAR SYSTEM AX=B. */
/* IERROR INTEGER. */
/* ERROR FLAG (NEGATIVE ERRORS ARE FATAL): */
/* (BELOW, A=SYSTEM MATRIX, Q=LEFT PRECONDITIONING MATRIX.) */
/* IERROR = 0 NORMAL RETURN: ITERATION CONVERGED */
/* IERROR = -1000 METHOD FAILED TO CONVERGE IN ITMAX STEPS */
/* IERROR = +-2000 ERROR IN USER INPUT */
/* IERROR = +-3000 METHOD BREAKDOWN */
/* IERROR = -6000 A DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* IERROR = -7000 Q DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* ***LONG DEDCRIPTION */
/* EACH CG ALGORITHM IN THE PACKAGE IS AN INSTANCE OF AN ORTHOGONAL */
/* ERROR METHOD. THE GENERAL FORM OF SUCH A METHOD IS: */
/* P0 = S0 = C*R0 */
/* ALPHA = <B*E,P>/<B*P,P> */
/* XNEW = X + ALPHA*P */
/* RNEW = R - ALPHA*(A*P) */
/* SNEW = C*RNEW */
/* BETA = <B*SNEW,P>/<B*P,P> */
/* PNEW = SNEW - BETA*P */
/* WHERE B IS A SYMMETRIC POSITIVE DEFINITE MATRIX AND C IS A */
/* PRECONDITIONING MATRIX. THE FOLLOWING CHOICES OF B AND C GIVE THE */
/* ALGORITHMS IN THE PACKAGE. THE QUANTITY MINIMIZED AT EACH STEP IS */
/* ALSO LISTED. */
/* ROUTINE B MATRIX C MATRIX QUANTITY MINIMIZED */
/* DCG A I <A*E E> */
/* DCR A*A I <R, R> */
/* DCRIND A*A I <R, R> */
/* DPCG A C <A*E, E> */
/* DCGNR AT*A AT <R, R> */
/* DCGNE I AT <E, E> */
/* DPCGNR AT*A C*CT*AT <R, R> */
/* DPCGNE I AT*CT*C <E, E> */
/* DPPCG A C(A)*C <A*E, E> */
/* DPCGCA C(A)*A C <C(A)*A*E, E> */
/* FOR SPECIFIC ALGORITHMS AND IMPLEMENTATION DETAILS SEE THE ROUTINE */
/* OF INTEREST. FOR MORE ON ORTHOGONAL ERROR METHODS SEE THE SECOND */
/* REFERENCE BELOW. */
/* WHEN THE USER SELECTS THE STOPPING CRITERION OPTION ISTOP=0, THEN */
/* THE CODES ALL ATTEMPT TO GUARANTEE THAT */
/* (FINAL ERROR) / (INITIAL ERROR) .LE. ERRTOL (1) */
/* THAT IS, THE CODES ATTEMPT TO REDUCE THE INITIAL ERROR BY ERRTOL. */
/* (IF X0=0, THEN ERRTOL IS ALSO A BOUND FOR THE RELATIVE ERROR IN */
/* THE COMPUTED SOLUTION, X.) TO SEE HOW (1) IS SATISFIED, CONSIDER */
/* THE SCALED SYSTEM C*AX = C*P. IF E(K) IS THE ERROR AT THE KTH */
/* STEP, THEN WE HAVE */
/* E(K)/E(0) .LE. COND(CA) * S(K)/S(0) */
/* WHERE S(K) = C*R(K) IS THE KTH SCALED RESIDUAL. THE S VECTORS ARE */
/* AVAILABLE FROM THE ITERATION. IF WE CAN ESTIMATE COND(CA), THEN */
/* EQUATION (1) IS SATISFIED WHEN */
/* COND(CA) * S(K)/S(0) .LE. ERRTOL. */
/* AN ESTIMATE FOR COND(CA) IS OBTAINED BY COMPUTING THE MIN AND MAX */
/* EIGENVALUES OF AN ORTHOGONAL SECTION OF C*A. THIS IS DONE EVERY */
/* ICYCLE STEPS. THE LARGEST ORTHOG SECTION HAS ORDER ICYCLE*NCE, */
/* WHERE NCE IS THE MAXIMUM NUMBER OF CONDITION ESTIMATES. TO SAVE */
/* STORAGE AND WORK, ICYCLE*NCE SHOULD BE MUCH LESS THAN N. IF NCE=0, */
/* NO CONDITION ESTIMATES ARE COMPUTED. IN THIS CASE, THE CODE STOPS */
/* WHEN S(K)/S(0) .LE. ERRTOL. SEE THE INDIVIDUAL SUBROUTINES' LONG */
/* DEDCRIPTIONS FOR DETAILS. */
/* THIS STOPPING CRITERION WAS IMPLEMENTED BY A.J. ROBERTSON, III */
/* (DEPT. OF MATHEMATICS, UNIV. OF COLORADO AT DENVER). QUESTIONS */
/* MAY BE DIRECTED TO HIM OR TO ONE OF THE AUTHORS. */
/* ***REFERENCES HOWARD C. ELMAN, "ITERATIVE METHODS FOR LARGE, SPARSE, */
/* NONSYMMETRIC SYSTEMS OF LINEAR EQUATIONS", YALE UNIV. */
/* DCS RESEARCH REPORT NO. 229 (APRIL 1982). */
/* VANCE FABER AND THOMAS MANTEUFFEL, "NECESSARY AND */
/* SUFFICIENT CONDITIONS FOR THE EXISTENCE OF A */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 21(2), */
/* PP. 352-362, 1984. */
/* S. ASHBY, T. MANTEUFFEL, AND P. SAYLOR, "A TAXONOMY FOR */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 27(6), */
/* PP. 1542-1568, 1990. */
/* S. ASHBY, M. HOLST, T. MANTEUFFEL, AND P. SAYLOR, */
/* THE ROLE OF THE INNER PRODUCT IN STOPPING CRITERIA */
/* FOR CONJUGATE GRADIENT ITERATIONS", BIT 41(1), */
/* PP. 26-53, 2001. */
/* M. HOLST, "CGCODE: SOFTWARE FOR SOLVING LINEAR SYSTEMS */
/* WITH CONJUGATE GRADIENT METHODS", M.S. THESIS, UNIV. */
/* OF ILLINOIS DCS RESEARCH REPORT (MAY 1990). */
/* S. ASHBY, "POLYNOMIAL PRECONDITIONG FOR CONJUGATE */
/* GRADIENT METHODS", PH.D. THESIS, UNIV. OF ILLINOIS */
/* DCS RESEARCH REPORT NO. R-87-1355 (DECEMBER 1987). */
/* S. ASHBY, M. SEAGER, "A PROPOSED STANDARD FOR ITERATIVE */
/* LINEAR SOLVERS", LAWRENCE LIVERMORE NATIONAL */
/* LABORATORY REPORT (TO APPEAR). */
/* ***ROUTINES CALLED DCG,DCRIND,DPCG,DCGNR,DCGNE,DPCGNR,DPCGNE, */
/* DPPCG,DPCGCA */
/* ***END PROLOGUE DCGDRV */
/* *** DECLARATIONS *** */
/* ***FIRST EXECUTABLE STATEMENT DCGDRV */
/* Parameter adjustments */
--rwork;
--iwork;
--rparam;
--iparam;
--ip;
--p;
--iq;
--q;
--b;
--x;
--ia;
--a;
/* Function Body */
/* L1: */
/* *** DECODE METHOD PARAMETER AND RWORK PARSING PARAMETERS *** */
iounit = iparam[5];
iolevl = iparam[6];
icg = iparam[33];
icycle = iparam[31];
nce = iparam[32];
kmax = icycle * nce;
/* *** CALL THE APPROPRIATE CGCODE SUBROUTINE *** */
if (iounit > 0 && iolevl > 0) {
io___7.ciunit = iounit;
s_wsfe(&io___7);
do_fio(&c__1, (char *)&icg, (ftnlen)sizeof(integer));
e_wsfe();
}
switch (icg) {
case 1: goto L11;
case 2: goto L12;
case 3: goto L13;
case 4: goto L14;
case 5: goto L15;
case 6: goto L16;
case 7: goto L17;
case 8: goto L18;
case 9: goto L19;
case 10: goto L20;
}
L11:
dcg_((U_fp)matvec, &a[1], &ia[1], &x[1], &b[1], n, &iparam[1], &rparam[1],
&iwork[1], &rwork[1], &rwork[*n + 1], &rwork[(*n << 1) + 1], &
rwork[(*n << 1) + kmax + 2], &rwork[(*n << 1) + (kmax << 1) + 3],
ierror);
goto L99;
L12:
dcr_((U_fp)matvec, &a[1], &ia[1], &x[1], &b[1], n, &iparam[1], &rparam[1],
&iwork[1], &rwork[1], &rwork[*n + 1], &rwork[(*n << 1) + 1], &
rwork[*n * 3 + 1], &rwork[*n * 3 + kmax + 2], &rwork[*n * 3 + (
kmax << 1) + 3], ierror);
goto L99;
L13:
dcrind_((U_fp)matvec, &a[1], &ia[1], &x[1], &b[1], n, &iparam[1], &rparam[
1], &iwork[1], &rwork[1], &rwork[*n + 1], &rwork[(*n << 1) + 1], &
rwork[*n * 3 + 1], &rwork[(*n << 2) + 1], &rwork[*n * 5 + 1], &
rwork[*n * 5 + kmax + 2], &rwork[*n * 5 + (kmax << 1) + 3],
ierror);
goto L99;
L14:
dpcg_((U_fp)matvec, (U_fp)pcondl, &a[1], &ia[1], &x[1], &b[1], n, &q[1], &
iq[1], &iparam[1], &rparam[1], &iwork[1], &rwork[1], &rwork[*n +
1], &rwork[(*n << 1) + 1], &rwork[(*n << 1) + kmax + 2], &rwork[(*
n << 1) + (kmax << 1) + 3], ierror);
goto L99;
L15:
dcgnr_((U_fp)matvec, &a[1], &ia[1], &x[1], &b[1], n, &iparam[1], &rparam[
1], &iwork[1], &rwork[1], &rwork[*n + 1], &rwork[(*n << 1) + 1], &
rwork[(*n << 1) + kmax + 2], &rwork[(*n << 1) + (kmax << 1) + 3],
ierror);
goto L99;
L16:
dcgne_((U_fp)matvec, &a[1], &ia[1], &x[1], &b[1], n, &iparam[1], &rparam[
1], &iwork[1], &rwork[1], &rwork[*n + 1], &rwork[(*n << 1) + 1], &
rwork[(*n << 1) + kmax + 2], &rwork[(*n << 1) + (kmax << 1) + 3],
ierror);
goto L99;
L17:
dpcgnr_((U_fp)matvec, (U_fp)pcondl, &a[1], &ia[1], &x[1], &b[1], n, &q[1],
&iq[1], &iparam[1], &rparam[1], &iwork[1], &rwork[1], &rwork[*n
+ 1], &rwork[(*n << 1) + 1], &rwork[*n * 3 + 1], &rwork[*n * 3 +
kmax + 2], &rwork[*n * 3 + (kmax << 1) + 3], ierror);
goto L99;
L18:
dpcgne_((U_fp)matvec, (U_fp)pcondl, &a[1], &ia[1], &x[1], &b[1], n, &q[1],
&iq[1], &iparam[1], &rparam[1], &iwork[1], &rwork[1], &rwork[*n
+ 1], &rwork[(*n << 1) + 1], &rwork[*n * 3 + 1], &rwork[*n * 3 +
kmax + 2], &rwork[*n * 3 + (kmax << 1) + 3], ierror);
goto L99;
L19:
dppcg_((U_fp)matvec, (U_fp)pcondl, &a[1], &ia[1], &x[1], &b[1], n, &q[1],
&iq[1], &iparam[1], &rparam[1], &iwork[1], &rwork[1], &rwork[*n +
1], &rwork[(*n << 1) + 1], &rwork[*n * 3 + 1], &rwork[(*n << 2) +
1], &rwork[*n * 5 + 1], &rwork[*n * 6 + 1], &rwork[*n * 6 + kmax
+ 2], ierror);
goto L99;
L20:
dpcgca_((U_fp)matvec, (U_fp)pcondl, &a[1], &ia[1], &x[1], &b[1], n, &q[1],
&iq[1], &iparam[1], &rparam[1], &iwork[1], &rwork[1], &rwork[*n
+ 1], &rwork[(*n << 1) + 1], &rwork[*n * 3 + 1], &rwork[(*n << 2)
+ 1], &rwork[*n * 5 + 1], &rwork[*n * 6 + 1], &rwork[*n * 6 +
kmax + 2], ierror);
/* *** RETURN *** */
L99:
return 0;
} /* dcgdrv_ */
/* ----------------------------------------------------------------------- */
/* Main program */ int MAIN__(void)
{
/* System generated locals */
address a__1[7];
integer i__1, i__2[7], i__3, i__4;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer f_rew(alist *), s_wsfe(cilist *), e_wsfe(void), s_wsfi(icilist *),
e_wsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, l, m, ld;
static char cmd[4];
static integer irc;
static real data[6];
static integer leng;
static char line[72];
static integer nred, nmem, ipos, kpos, iout;
static char type__[1];
static real work[300000];
static integer ldata;
static char aleng[6];
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iomls, iotxt;
extern /* Subroutine */ int setli1_(char *, integer *, real *, integer *,
ftnlen), setli2_(char *, integer *, real *, integer *, ftnlen),
setli3_(char *, integer *, real *, integer *, ftnlen);
static char member[8], dirnam[72], memnam[8*4000];
extern /* Subroutine */ int setlin_(char *, integer *, real *, ftnlen),
memlst_(integer *, integer *, char *, ftnlen), uioset_(void),
txtlin_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 5, 0, "(A72)", 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___13 = { 0, 0, 0, "(A72)", 0 };
static cilist io___16 = { 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___24 = { 0, 6, 0, 0, 0 };
static icilist io___26 = { 0, aleng, 0, "(I6)", 6, 1 };
static cilist io___27 = { 0, 0, 0, "(A72)", 0 };
static cilist io___35 = { 0, 0, 0, "(A72)", 0 };
static cilist io___36 = { 0, 0, 0, "(A72)", 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
/* ----- IO DEVICE */
/* IOTXT : TEXT PDS (WRITE) */
/* IOMLS : MEMBER LIST (READ) */
/* IOUT : STANDARD OUTPUT (WRITE) */
/* 49 : DEVICE FOR PDS MEMBER, INTERNALLY OPENED AND CLOSED (READ) */
/* 5 : STANDARD INPUT FOR DIRECTORY NAME OF PDS FILE */
uioset_();
iotxt = 10;
iomls = 11;
iout = 6;
nred = 0;
s_copy(cmd, "*PUT", (ftnlen)4, (ftnlen)4);
*(unsigned char *)type__ = 'N';
/* ******************** */
/* READ INPUT DATA * */
/* ******************** */
/* DIRNAM : FULL NAME OF DIRECTORY FOR PDS */
/* EX:/DG05/UFS02/J9347/SRAC95/LIB/PDS/PFAST/PFASTJ2 */
s_rsfe(&io___7);
do_fio(&c__1, dirnam, (ftnlen)72);
e_rsfe();
if (*(unsigned char *)dirnam == ' ') {
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ERROR(MAIN) : DIRECTORY NAME IS INVALID", (
ftnlen)40);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, " THE FIRST COLUMN SHOULD BE NON-BLANK", (ftnlen)
37);
e_wsle();
s_wsle(&io___11);
do_lio(&c__9, &c__1, " DIRNAM = ", (ftnlen)10);
do_lio(&c__9, &c__1, dirnam, (ftnlen)72);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ************************ */
/* WRITE HEADER IN TEXT * */
/* ************************ */
al__1.aerr = 0;
al__1.aunit = iotxt;
f_rew(&al__1);
s_copy(line, " 3 PDSEDT INPUT R/W MODE ", (ftnlen)72, (ftnlen)34)
;
io___13.ciunit = iotxt;
s_wsfe(&io___13);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ******************** */
/* READ MEMBER LIST * */
/* ******************** */
memlst_(&iomls, &nmem, memnam, (ftnlen)8);
if (nmem > 4000) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, " ERROR (MAIN) : MAX OF MEMBER(MAXME=", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&c__4000, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30);
do_lio(&c__3, &c__1, (char *)&nmem, (ftnlen)sizeof(integer));
e_wsle();
s_stop("", (ftnlen)0);
}
/* ******************** */
/* LOOP ON MEMBER * */
/* ******************** */
i__1 = nmem;
for (m = 1; m <= i__1; ++m) {
s_copy(member, memnam + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
setdt_1.ntnuc1 = 0;
setdt_1.ntnuc2 = 0;
setdt_1.nzon2 = 0;
setdt_1.nzon3 = 0;
/* *************************** */
/* READ CONTENTS OF MEMBER * */
/* *************************** */
pdsin_(dirnam, member, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)
8);
if (irc != 0) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " PDS ERROR : ERROR CODE = ", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___23);
do_lio(&c__9, &c__1, " MEMBER = ", (ftnlen)10);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
} else {
++nred;
}
if (leng > 300000) {
s_wsle(&io___24);
do_lio(&c__9, &c__1, " ERROR (MAIN) : WORK AREA(MAXWK=", (ftnlen)
32);
do_lio(&c__3, &c__1, (char *)&c_b48, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30)
;
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " IN MEMBER:", (ftnlen)11);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ***************** */
/* WRITE IN TEXT * */
/* ***************** */
/* ----- WRITE MEMBER NAME AND LENGTH */
s_wsfi(&io___26);
do_fio(&c__1, (char *)&leng, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__1[0] = cmd;
i__2[1] = 1, a__1[1] = " ";
i__2[2] = 8, a__1[2] = member;
i__2[3] = 1, a__1[3] = " ";
i__2[4] = 1, a__1[4] = type__;
i__2[5] = 1, a__1[5] = " ";
i__2[6] = 6, a__1[6] = aleng;
s_cat(line, a__1, i__2, &c__7, (ftnlen)72);
io___27.ciunit = iotxt;
s_wsfe(&io___27);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ----- SET NUMBER OF LINES TO WRITE IN TEXT FOR DATA OF A MEMBER */
txtlin_(&leng, &ldata);
/* ----- SET LINE DATA AND WRITE IN TEXT */
i__3 = ldata;
for (l = 1; l <= i__3; ++l) {
kpos = (l - 1) * 6 + 1;
if (l != ldata) {
ld = 6;
} else {
ld = leng - (ldata - 1) * 6;
}
i__4 = ld;
for (i__ = 1; i__ <= i__4; ++i__) {
ipos = (l - 1) * 6 + i__;
data[i__ - 1] = work[ipos - 1];
/* L110: */
}
if (s_cmp(member + 4, "DN", (ftnlen)2, (ftnlen)2) == 0 && *(
unsigned char *)&member[7] == 'T') {
setli1_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "BNUP", (ftnlen)4, (ftnlen)4) == 0) {
setli2_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "REST", (ftnlen)4, (ftnlen)4) == 0) {
setli3_(line, &ld, data, &kpos, (ftnlen)72);
} else {
setlin_(line, &ld, data, (ftnlen)72);
}
io___35.ciunit = iotxt;
s_wsfe(&io___35);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* L100: */
}
/* L1000: */
}
/* *********** */
/* FINISH * */
/* *********** */
s_copy(line, "*FIN", (ftnlen)72, (ftnlen)4);
io___36.ciunit = iotxt;
s_wsfe(&io___36);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
io___37.ciunit = iout;
s_wsle(&io___37);
e_wsle();
io___38.ciunit = iout;
s_wsle(&io___38);
do_lio(&c__9, &c__1, " NUMBER OF MEMBERS READ FROM PDS=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&nred, (ftnlen)sizeof(integer));
e_wsle();
io___39.ciunit = iout;
s_wsle(&io___39);
do_lio(&c__9, &c__1, " ********** JOB END **********", (ftnlen)30);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int dchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where DGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where DGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where DGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9993[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9992[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
doublereal a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[
2500] /* was [50][50] */, f[2500] /* was [50][50] */;
integer i__, j, m, n;
doublereal af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */,
vl[2500] /* was [50][50] */, vr[2500] /* was [50][50] */;
integer ihi, ilo;
doublereal eps, vlf[2500] /* was [50][50] */;
integer knt;
doublereal vrf[2500] /* was [50][50] */;
integer info, lmax[4];
doublereal rmax, vmax, work[2500] /* was [50][50] */;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer ninfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal lscale[50], rscale[50];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGK tests DGGBAK, a routine for backward balancing of */
/* a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialization */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L50: */
}
++knt;
anorm = dlange_("M", &n, &n, a, &c__50, work);
bnorm = dlange_("M", &n, &n, b, &c__50, work);
dlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
dlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
dggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
dlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
dlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
dggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
dggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of DGGBAK */
/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/* where tilde(A) denotes the transformed matrix. */
dgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
dgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
- 51], abs(d__1));
vmax = max(d__2,d__3);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
dgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
dgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
- 51], abs(d__1));
vmax = max(d__2,d__3);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKGK */
} /* dchkgk_ */
/* Subroutine */ int ddrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
integer *nounit, doublereal *a, integer *lda, doublereal *h__,
doublereal *wr, doublereal *wi, doublereal *wr1, doublereal *wi1,
doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
doublereal *lre, integer *ldlre, doublereal *rcondv, doublereal *
rcndv1, doublereal *rcdvin, doublereal *rconde, doublereal *rcnde1,
doublereal *rcdein, doublereal *scale, doublereal *scale1, doublereal
*result, doublereal *work, integer *nwork, integer *iwork, integer *
info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 DDRVVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
"composition\002,\002 Expert Driver\002,/\002 Matrix types (see D"
"DRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, n, iwk;
doublereal ulp;
integer ibal;
doublereal cond;
integer jcol;
char path[3];
integer nmax;
doublereal unfl, ovfl;
logical badnn;
extern /* Subroutine */ int dget23_(logical *, char *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *);
integer nfail, imode, iinfo;
doublereal conds, anorm;
integer jsize, nerrs, itype, jtype, ntest;
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
char balanc[1];
extern doublereal dlamch_(char *);
char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
integer idumma[1];
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), dlatmr_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, char *, char *, doublereal
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
char *, integer *, integer *, integer *, doublereal *,
doublereal *, char *, doublereal *, integer *, integer *, integer
*), dlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublereal *, integer *, doublereal *, integer *), dlasum_(char *, integer *, integer *, integer *);
integer ntestf, nnwork;
doublereal rtulpi;
integer mtypes, ntestt;
doublereal ulpinv;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVVX checks the nonsymmetric eigenvalue problem expert driver */
/* DGEEVX. */
/* DDRVVX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When DDRVVX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified in the calling sequence. */
/* For each size ("n") and each type of matrix, one matrix will be */
/* generated and used to test the nonsymmetric eigenroutines. For */
/* each matrix, 9 tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a block diagonal matrix, with a 1x1 block for each */
/* real eigenvalue and a 2x2 block for each complex conjugate */
/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
/* 2 x 2 block corresponding to the pair will be: */
/* ( wr wi ) */
/* ( -wi wr ) */
/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
/* and RCONDE are also computed, and W(partial) denotes the */
/* eigenvalues computed when only some of VR, VL, RCONDV, and */
/* RCONDE are computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
/* and RCONDE are computed, and VR(partial) denotes the result */
/* when only some of VL and RCONDV are computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
/* and RCONDE are computed, and VL(partial) denotes the result */
/* when only some of VR and RCONDV are computed. */
/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
/* SCALE, ILO, IHI, ABNRM (partial) */
/* 1/ulp otherwise */
/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
/* (partial) is when some are not computed. */
/* (9) RCONDV(full) = RCONDV(partial) */
/* RCONDV(full) denotes the reciprocal condition numbers of the */
/* right eigenvectors computed when VR, VL and RCONDE are also */
/* computed. RCONDV(partial) denotes the reciprocal condition */
/* numbers when only some of VR, VL and RCONDE are computed. */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is orthogonal and */
/* T has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is orthogonal and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (12) A matrix of the form U' T U, where U is orthogonal and */
/* T has real or complex conjugate paired eigenvalues randomly */
/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random signs on the diagonal and random */
/* O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has real or complex conjugate paired */
/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
/* O(1) entries in the upper triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalues */
/* and right eigenvectors. For these matrices, in addition to tests */
/* (1) to (9) we will compute the following two tests: */
/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right eigenvector condition number */
/* computed by DGEEVX and RCDVIN (the precomputed true value) */
/* is supplied as input. cond(RCONDV) is the condition number of */
/* RCONDV, and takes errors in computing RCONDV into account, so */
/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
/* essentially given by norm(A)/RCONDE. */
/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal eigenvalue condition number */
/* computed by DGEEVX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRVVX to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) DOUBLE PRECISION array, dimension */
/* (LDA, max(NN,12)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A and H. */
/* LDA >= max(NN,12), since 12 is the dimension of the largest */
/* matrix in the precomputed input file. */
/* H (workspace) DOUBLE PRECISION array, dimension */
/* (LDA, max(NN,12)) */
/* Another copy of the test matrix A, modified by DGEEVX. */
/* WR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* WI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* The real and imaginary parts of the eigenvalues of A. */
/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
/* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12)) */
/* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12)) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but those computed when DGEEVX only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) DOUBLE PRECISION array, dimension */
/* (LDVL, max(NN,12)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
/* VR (workspace) DOUBLE PRECISION array, dimension */
/* (LDVR, max(NN,12)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
/* LRE (workspace) DOUBLE PRECISION array, dimension */
/* (LDLRE, max(NN,12)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
/* RCONDV (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCONDV holds the computed reciprocal condition numbers */
/* for eigenvectors. */
/* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCNDV1 holds more computed reciprocal condition numbers */
/* for eigenvectors. */
/* RCDVIN (workspace) DOUBLE PRECISION array, dimension (N) */
/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
/* condition numbers for eigenvectors to be compared with */
/* RCONDV. */
/* RCONDE (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCONDE holds the computed reciprocal condition numbers */
/* for eigenvalues. */
/* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCNDE1 holds more computed reciprocal condition numbers */
/* for eigenvalues. */
/* RCDEIN (workspace) DOUBLE PRECISION array, dimension (N) */
/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
/* condition numbers for eigenvalues to be compared with */
/* RCONDE. */
/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
/* IWORK (workspace) INTEGER array, dimension (2*max(NN,12)) */
/* INFO (output) INTEGER */
/* If 0, then successful exit. */
/* If <0, then input paramter -INFO is incorrect. */
/* If >0, DLATMR, SLATMS, SLATME or DGET23 returned an error */
/* code, and INFO is its absolute value. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN or 12. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
--wr1;
--wi1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -17;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -19;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -21;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -32;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
if (jcol > 1) {
a[jcol + (jcol - 1) * a_dim1] = 1.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
3], lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
a_dim1 + 3], lda);
dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___33.ciunit = *nounit;
s_wsfe(&io___33);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
dget23_(&c_false, balanc, &jtype, thresh, ioldsd, nounit,
&n, &a[a_offset], lda, &h__[h_offset], &wr[1], &
wi[1], &wr1[1], &wi1[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &
rcnde1[1], &rcdein[1], &scale[1], &scale1[1], &
result[1], &work[1], &nnwork, &iwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation. */
/* Assume input eigenvalues are sorted lexicographically (increasing */
/* by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___46.ciunit = *niunit;
i__1 = s_rsle(&io___46);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__5, &c__1, (char *)&wr1[i__], (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&wi1[i__], (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(doublereal))
;
e_rsle();
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
dget23_(&c_true, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset],
lda, &h__[h_offset], &wr[1], &wi[1], &wr1[1], &wi1[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &work[1], &i__1, &
iwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
e_wsfe();
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of DDRVVX */
} /* ddrvvx_ */
/* Subroutine */ int zdrvls_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nns, integer *nsval, integer *
nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
tsterr, doublecomplex *a, doublecomplex *copya, doublecomplex *b,
doublecomplex *copyb, doublecomplex *c__, doublereal *s, doublereal *
copys, doublecomplex *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
"=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
"\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
doublereal eps;
integer ins, info;
char path[3];
integer rank, nrhs, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], crank, irank;
doublereal rcond;
extern doublereal dasum_(integer *, doublereal *, integer *);
integer itran, mnmin, ncols;
doublereal norma, normb;
extern /* Subroutine */ int zgels_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
zgemm_(char *, char *, integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
char trans[1];
integer nerrs, itype, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zqrt14_(char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zqrt13_(integer *, integer *, integer *,
doublecomplex *, integer *, doublereal *, integer *), zqrt15_(
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublecomplex *, integer *);
integer nrows;
extern doublereal zqrt17_(char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer lwlsy;
extern /* Subroutine */ int zqrt16_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
integer iscale;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), zgelsd_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, integer *, doublecomplex *, integer *
, doublereal *, integer *, integer *), xlaenv_(integer *, integer
*);
integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zgelss_(integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, doublereal *, doublereal *,
integer *, doublecomplex *, integer *, doublereal *, integer *),
zgelsx_(integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, integer *, doublereal *, integer *,
doublecomplex *, doublereal *, integer *), zgelsy_(integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublereal *, integer *, doublecomplex *,
integer *, doublereal *, integer *);
doublereal result[18];
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *), zerrls_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 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 .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVLS tests the least squares driver routines ZGELS, CGELSX, CGELSS, */
/* ZGELSY and CGELSD. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* The matrix of type j is generated as follows: */
/* j=1: A = U*D*V where U and V are random unitary matrices */
/* and D has random entries (> 0.1) taken from a uniform */
/* distribution (0,1). A is full rank. */
/* j=2: The same of 1, but A is scaled up. */
/* j=3: The same of 1, but A is scaled down. */
/* j=4: A = U*D*V where U and V are random unitary matrices */
/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
/* from a uniform distribution (0,1) and the remaining */
/* entries set to 0. A is rank-deficient. */
/* j=5: The same of 4, but A is scaled up. */
/* j=6: The same of 5, but A is scaled down. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
/* maximum value of NRHS in NSVAL. */
/* COPYB (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* C (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*NMAX-1) */
/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--copys;
--s;
--c__;
--copyb;
--b;
--copya;
--a;
--nxval;
--nbval;
--nsval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Threshold for rank estimation */
rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
/* Test the error exits */
xlaenv_(&c__9, &c__25);
if (*tsterr) {
zerrls_(path, nout);
}
/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
alahd_(nout, path);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = max(1,m);
ldb = max(i__3,n);
i__3 = *nns;
for (ins = 1; ins <= i__3; ++ins) {
nrhs = nsval[ins];
/* Computing MAX */
i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
i__4,i__5), i__5 = (n << 1) + m;
lwork = max(i__4,i__5);
for (irank = 1; irank <= 2; ++irank) {
for (iscale = 1; iscale <= 3; ++iscale) {
itype = (irank - 1) * 3 + iscale;
if (! dotype[itype]) {
goto L100;
}
if (irank == 1) {
/* Test ZGELS */
/* Generate a matrix of scaling type ISCALE */
zqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
iseed);
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)trans = 'N';
nrows = m;
ncols = n;
} else {
*(unsigned char *)trans = 'C';
nrows = n;
ncols = m;
}
ldwork = max(1,ncols);
/* Set up a consistent rhs */
if (ncols > 0) {
i__5 = ncols * nrhs;
zlarnv_(&c__2, iseed, &i__5, &work[1])
;
i__5 = ncols * nrhs;
d__1 = 1. / (doublereal) ncols;
zdscal_(&i__5, &d__1, &work[1], &c__1)
;
}
zgemm_(trans, "No transpose", &nrows, &
nrhs, &ncols, &c_b1, ©a[1], &
lda, &work[1], &ldwork, &c_b2, &b[
1], &ldb);
zlacpy_("Full", &nrows, &nrhs, &b[1], &
ldb, ©b[1], &ldb);
/* Solve LS or overdetermined system */
if (m > 0 && n > 0) {
zlacpy_("Full", &m, &n, ©a[1], &
lda, &a[1], &lda);
zlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &b[1], &ldb);
}
s_copy(srnamc_1.srnamt, "ZGELS ", (ftnlen)
6, (ftnlen)6);
zgels_(trans, &m, &n, &nrhs, &a[1], &lda,
&b[1], &ldb, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "ZGELS ", &info, &c__0,
trans, &m, &n, &nrhs, &c_n1, &
nb, &itype, &nfail, &nerrs,
nout);
}
/* Check correctness of results */
ldwork = max(1,nrows);
if (nrows > 0 && nrhs > 0) {
zlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &c__[1], &ldb);
}
zqrt16_(trans, &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &c__[1], &ldb, &
rwork[1], result);
if (itran == 1 && m >= n || itran == 2 &&
m < n) {
/* Solving LS system */
result[1] = zqrt17_(trans, &c__1, &m,
&n, &nrhs, ©a[1], &lda, &
b[1], &ldb, ©b[1], &ldb, &
c__[1], &work[1], &lwork);
} else {
/* Solving overdetermined system */
result[1] = zqrt14_(trans, &m, &n, &
nrhs, ©a[1], &lda, &b[1],
&ldb, &work[1], &lwork);
}
/* Print information about the tests that */
/* did not pass the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, trans, (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 *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itype, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 2;
/* L30: */
}
/* L40: */
}
}
/* Generate a matrix of scaling type ISCALE and rank */
/* type IRANK. */
zqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
lda, ©b[1], &ldb, ©s[1], &rank, &
norma, &normb, iseed, &work[1], &lwork);
/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
iwork[j] = 0;
/* L50: */
}
ldwork = max(1,m);
/* Test ZGELSX */
/* ZGELSX: Compute the minimum-norm solution X */
/* to min( norm( A * X - B ) ) */
/* using a complete orthogonal factorization. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
ldb);
s_copy(srnamc_1.srnamt, "ZGELSX", (ftnlen)6, (ftnlen)
6);
zgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &rwork[1],
&info);
if (info != 0) {
alaerh_(path, "ZGELSX", &info, &c__0, " ", &m, &n,
&nrhs, &c_n1, &nb, &itype, &nfail, &
nerrs, nout);
}
/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
/* Test 3: Compute relative error in svd */
/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[2] = zqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork, &rwork[1]);
/* Test 4: Compute error in solution */
/* workspace: M*NRHS + M */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
&ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &work[1], &ldwork, &rwork[1]
, &result[3]);
/* Test 5: Check norm of r'*A */
/* workspace: NRHS*(M+N) */
result[4] = 0.;
if (m > crank) {
result[4] = zqrt17_("No transpose", &c__1, &m, &n,
&nrhs, ©a[1], &lda, &b[1], &ldb, &
copyb[1], &ldb, &c__[1], &work[1], &lwork);
}
/* Test 6: Check if x is in the rowspace of A */
/* workspace: (M+NRHS)*(N+2) */
result[5] = 0.;
if (n > crank) {
result[5] = zqrt14_("No transpose", &m, &n, &nrhs,
©a[1], &lda, &b[1], &ldb, &work[1], &
lwork);
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 3; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 4;
/* Loop for testing different block sizes. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
/* Test ZGELSY */
/* ZGELSY: Compute the minimum-norm solution */
/* X to min( norm( A * X - B ) ) */
/* using the rank-revealing orthogonal */
/* factorization. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
/* Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L70: */
}
/* Set LWLSY to the adequate value. */
/* Computing MAX */
i__5 = mnmin << 1, i__6 = nb * (n + 1), i__5 =
max(i__5,i__6), i__6 = mnmin + nb * nrhs;
lwlsy = mnmin + max(i__5,i__6);
lwlsy = max(1,lwlsy);
s_copy(srnamc_1.srnamt, "ZGELSY", (ftnlen)6, (
ftnlen)6);
zgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &
lwlsy, &rwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSY", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) */
/* Test 7: Compute relative error in svd */
/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[6] = zqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork, &rwork[1]);
/* Test 8: Compute error in solution */
/* workspace: M*NRHS + M */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[7]);
/* Test 9: Check norm of r'*A */
/* workspace: NRHS*(M+N) */
result[8] = 0.;
if (m > crank) {
result[8] = zqrt17_("No transpose", &c__1, &m,
&n, &nrhs, ©a[1], &lda, &b[1], &
ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 10: Check if x is in the rowspace of A */
/* workspace: (M+NRHS)*(N+2) */
result[9] = 0.;
if (n > crank) {
result[9] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test ZGELSS */
/* ZGELSS: Compute the minimum-norm solution */
/* X to min( norm( A * X - B ) ) */
/* using the SVD. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "ZGELSS", (ftnlen)6, (
ftnlen)6);
zgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
rwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSS", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 3*min(m,n) + */
/* max(2*min(m,n),nrhs,max(m,n)) */
/* Test 11: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
, &c__1);
result[10] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[10] = 0.;
}
/* Test 12: Compute error in solution */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[11]);
/* Test 13: Check norm of r'*A */
result[12] = 0.;
if (m > crank) {
result[12] = zqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 14: Check if x is in the rowspace of A */
result[13] = 0.;
if (n > crank) {
result[13] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test ZGELSD */
/* ZGELSD: Compute the minimum-norm solution X */
/* to min( norm( A * X - B ) ) using a */
/* divide and conquer SVD. */
xlaenv_(&c__9, &c__25);
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "ZGELSD", (ftnlen)6, (
ftnlen)6);
zgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
rwork[1], &iwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSD", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 15: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
, &c__1);
result[14] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[14] = 0.;
}
/* Test 16: Compute error in solution */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[15]);
/* Test 17: Check norm of r'*A */
result[16] = 0.;
if (m > crank) {
result[16] = zqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 18: Check if x is in the rowspace of A */
result[17] = 0.;
if (n > crank) {
result[17] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 7; k <= 18; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun += 12;
/* L90: */
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVLS */
} /* zdrvls_ */
