/* Subroutine */ int serrgt_(char *path, integer *nunit)
{
/* System generated locals */
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real b[2], c__[2], d__[2], e[2], f[2], w[2], x[2];
char c2[2];
real r1[2], r2[2], cf[2], df[2], ef[2];
integer ip[2], iw[2], info;
real rcond, anorm;
extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), sgtcon_(char *, integer *, real *, real *,
real *, real *, integer *, real *, real *, real *, integer *,
integer *), sptcon_(integer *, real *, real *, real *,
real *, real *, integer *), sgtrfs_(char *, integer *, integer *,
real *, real *, real *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, real *, real *, real *,
integer *, integer *), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *), sptrfs_(integer *, integer
*, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, real *, real *, integer *), spttrf_(integer *,
real *, real *, integer *), sgttrs_(char *, integer *, integer *,
real *, real *, real *, real *, integer *, real *, integer *,
integer *), spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRGT tests the error exits for the REAL tridiagonal */
/* routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
d__[0] = 1.f;
d__[1] = 2.f;
df[0] = 1.f;
df[1] = 2.f;
e[0] = 3.f;
e[1] = 4.f;
ef[0] = 3.f;
ef[1] = 4.f;
anorm = 1.f;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GT")) {
/* Test error exits for the general tridiagonal routines. */
/* SGTTRF */
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgttrf_(&c_n1, c__, d__, e, f, ip, &info);
chkxer_("SGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTTRS */
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgttrs_("/", &c__0, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgttrs_("N", &c_n1, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgttrs_("N", &c__0, &c_n1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgttrs_("N", &c__2, &c__1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTRFS */
s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgtrfs_("/", &c__0, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgtrfs_("N", &c_n1, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgtrfs_("N", &c__0, &c_n1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__2, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__2,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGTCON */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgtcon_("/", &c__0, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgtcon_("I", &c_n1, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
r__1 = -anorm;
sgtcon_("I", &c__0, c__, d__, e, f, ip, &r__1, &rcond, w, iw, &info);
chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PT")) {
/* Test error exits for the positive definite tridiagonal */
/* routines. */
/* SPTTRF */
s_copy(srnamc_1.srnamt, "SPTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spttrf_(&c_n1, d__, e, &info);
chkxer_("SPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTTRS */
s_copy(srnamc_1.srnamt, "SPTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
spttrs_(&c_n1, &c__0, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
spttrs_(&c__0, &c_n1, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
spttrs_(&c__2, &c__1, d__, e, x, &c__1, &info);
chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTRFS */
s_copy(srnamc_1.srnamt, "SPTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sptrfs_(&c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sptrfs_(&c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, &
info);
chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SPTCON */
s_copy(srnamc_1.srnamt, "SPTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sptcon_(&c_n1, d__, e, &anorm, &rcond, w, &info);
chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
r__1 = -anorm;
sptcon_(&c__0, d__, e, &r__1, &rcond, w, &info);
chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRGT */
} /* serrgt_ */
/* Subroutine */ int schkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
real *af, real *b, real *x, real *xact, real *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer in, kl, ku, ix, lda;
real 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];
real rcond;
integer nimat;
real anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
real rcondc, rcondi, rcondo;
real ainvnm;
logical trfcon;
real 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 */
/* ======= */
/* SCHKGT tests SGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
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) {
serrge_(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 SLATB4. */
slatb4_(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, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&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 SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&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) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from SGTTRF. */
if (info != izero) {
alaerh_(path, "SGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use SGTTRS to solve for one column at a time of inv(A) */
/* or inv(A^T), computing the maximum column sum as we */
/* go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.f;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
sgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
iwork[n + 1], &info);
/* Check error code from SGTCON. */
if (info != 0) {
alaerh_(path, "SGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
slarnv_(&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. */
slagtm_(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. */
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
sgttrs_(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 SGTTRS. */
if (info != 0) {
alaerh_(path, "SGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(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. */
sget04_(&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, "SGTRFS", (ftnlen)32, (ftnlen)6);
sgtrfs_(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], &iwork[n +
1], &info);
/* Check error code from SGTRFS. */
if (info != 0) {
alaerh_(path, "SGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
sgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKGT */
} /* schkgt_ */
/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, real *dl, real *d, real *du, real *dlf, real *df, real *duf,
real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* -- LAPACK 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
=======
SGTSVX uses the LU factorization to compute the solution to a real
system of linear equations A * X = B or A**T * X = B,
where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the LU decomposition is used to factor the matrix A
as A = L * U, where L is a product of permutation and unit lower
bidiagonal matrices and U is upper triangular with nonzeros in
only the main diagonal and first two superdiagonals.
2. The factored form of A is used to estimate the condition number
of the matrix A. If the reciprocal of the condition number is
less than machine precision, steps 3 and 4 are skipped.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
will not be modified.
= 'N': The matrix will be copied to DLF, DF, and DUF
and factored.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) REAL array, dimension (N)
The n diagonal elements of A.
DU (input) REAL array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DLF is an input argument and on entry
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A as computed by SGTTRF.
If FACT = 'N', then DLF is an output argument and on exit
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A.
DF (input or output) REAL array, dimension (N)
If FACT = 'F', then DF is an input argument and on entry
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
If FACT = 'N', then DF is an output argument and on exit
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
DUF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DUF is an input argument and on entry
contains the (n-1) elements of the first superdiagonal of U.
If FACT = 'N', then DUF is an output argument and on exit
contains the (n-1) elements of the first superdiagonal of U.
DU2 (input or output) REAL array, dimension (N-2)
If FACT = 'F', then DU2 is an input argument and on entry
contains the (n-2) elements of the second superdiagonal of
U.
If FACT = 'N', then DU2 is an output argument and on exit
contains the (n-2) elements of the second superdiagonal of
U.
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains the pivot indices from the LU factorization of A as
computed by SGTTRF.
If FACT = 'N', then IPIV is an output argument and on exit
contains the pivot indices from the LU factorization of A;
row i of the matrix was interchanged with row IPIV(i).
IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
a row interchange was not required.
B (input) REAL array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0, the N-by-NRHS solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A. If RCOND is less than the machine precision (in
particular, if RCOND = 0), the matrix is singular to working
precision. This condition is indicated by a return code of
INFO > 0, and the solution and error bounds are not computed.
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) REAL array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: U(i,i) is exactly zero. The factorization
has not been completed unless i = N, but the
factor U is exactly singular, so the solution
and error bounds could not be computed.
= N+1: RCOND is less than machine precision. The
factorization has been completed, but the
matrix is singular to working precision, and
the solution and error bounds have not been
computed.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
static char norm[1];
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slangt_(char *, integer *, real *, real *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), sgtcon_(char *, integer *,
real *, real *, real *, real *, integer *, real *, real *, real *,
integer *, integer *);
static logical notran;
extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sgttrf_(integer *, real *, real *, real *,
real *, integer *, integer *), sgttrs_(char *, integer *, integer
*, real *, real *, real *, real *, integer *, real *, integer *,
integer *);
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
nofact = lsame_(fact, "N");
notran = lsame_(trans, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
scopy_(n, &D(1), &c__1, &DF(1), &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &DL(1), &c__1, &DLF(1), &c__1);
i__1 = *n - 1;
scopy_(&i__1, &DU(1), &c__1, &DUF(1), &c__1);
}
sgttrf_(n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, n, &DL(1), &D(1), &DU(1));
/* Compute the reciprocal of the condition number of A. */
sgtcon_(norm, n, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &anorm,
rcond, &WORK(1), &IWORK(1), info);
/* Return if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
return 0;
}
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
sgttrs_(trans, n, nrhs, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(1), &X(1,1), ldx, info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
sgtrfs_(trans, n, nrhs, &DL(1), &D(1), &DU(1), &DLF(1), &DF(1), &DUF(1), &
DU2(1), &IPIV(1), &B(1,1), ldb, &X(1,1), ldx, &FERR(1),
&BERR(1), &WORK(1), &IWORK(1), info);
return 0;
/* End of SGTSVX */
} /* sgtsvx_ */
/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf,
real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
char norm[1];
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slangt_(char *, integer *, real *, real *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), sgtcon_(char *, integer *,
real *, real *, real *, real *, integer *, real *, real *, real *,
integer *, integer *);
logical notran;
extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sgttrf_(integer *, real *, real *, real *,
real *, integer *, integer *), sgttrs_(char *, integer *, integer
*, real *, real *, real *, real *, integer *, real *, integer *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGTSVX uses the LU factorization to compute the solution to a real */
/* system of linear equations A * X = B or A**T * X = B, */
/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */
/* matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */
/* as A = L * U, where L is a product of permutation and unit lower */
/* bidiagonal matrices and U is upper triangular with nonzeros in */
/* only the main diagonal and first two superdiagonals. */
/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */
/* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */
/* will not be modified. */
/* = 'N': The matrix will be copied to DLF, DF, and DUF */
/* and factored. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* DL (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of A. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of A. */
/* DU (input) REAL array, dimension (N-1) */
/* The (n-1) superdiagonal elements of A. */
/* DLF (input or output) REAL array, dimension (N-1) */
/* If FACT = 'F', then DLF is an input argument and on entry */
/* contains the (n-1) multipliers that define the matrix L from */
/* the LU factorization of A as computed by SGTTRF. */
/* If FACT = 'N', then DLF is an output argument and on exit */
/* contains the (n-1) multipliers that define the matrix L from */
/* the LU factorization of A. */
/* DF (input or output) REAL array, dimension (N) */
/* If FACT = 'F', then DF is an input argument and on entry */
/* contains the n diagonal elements of the upper triangular */
/* matrix U from the LU factorization of A. */
/* If FACT = 'N', then DF is an output argument and on exit */
/* contains the n diagonal elements of the upper triangular */
/* matrix U from the LU factorization of A. */
/* DUF (input or output) REAL array, dimension (N-1) */
/* If FACT = 'F', then DUF is an input argument and on entry */
/* contains the (n-1) elements of the first superdiagonal of U. */
/* If FACT = 'N', then DUF is an output argument and on exit */
/* contains the (n-1) elements of the first superdiagonal of U. */
/* DU2 (input or output) REAL array, dimension (N-2) */
/* If FACT = 'F', then DU2 is an input argument and on entry */
/* contains the (n-2) elements of the second superdiagonal of */
/* U. */
/* If FACT = 'N', then DU2 is an output argument and on exit */
/* contains the (n-2) elements of the second superdiagonal of */
/* U. */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains the pivot indices from the LU factorization of A as */
/* computed by SGTTRF. */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains the pivot indices from the LU factorization of A; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */
/* a row interchange was not required. */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) REAL array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A. If RCOND is less than the machine precision (in */
/* particular, if RCOND = 0), the matrix is singular to working */
/* precision. This condition is indicated by a return code of */
/* INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) REAL array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: U(i,i) is exactly zero. The factorization */
/* has not been completed unless i = N, but the */
/* factor U is exactly singular, so the solution */
/* and error bounds could not be computed. */
/* RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
notran = lsame_(trans, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
}
sgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, n, &dl[1], &d__[1], &du[1]);
/* Compute the reciprocal of the condition number of A. */
sgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
rcond, &work[1], &iwork[1], info);
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
sgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
sgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
&du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
, &berr[1], &work[1], &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of SGTSVX */
} /* sgtsvx_ */
/* Subroutine */ int stimgt_(char *line, integer *nm, integer *mval, integer *
nns, integer *nsval, integer *nlda, integer *ldaval, real *timmin,
real *a, real *b, integer *iwork, real *reslts, integer *ldr1,
integer *ldr2, integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*4] = "SGTTRF" "SGTTRS" "SGTSV " "SGTSL ";
static char transs[1*2] = "N" "T";
/* Format strings */
static char fmt_9998[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9997[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9996[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9999[] = "(\002 SGTTRS with TRANS = '\002,a1,\002'\002,/)"
;
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda, info;
static char path[3];
static real time;
static integer isub, nrhs, i__, m, n;
static char cname[6];
static integer laval[1];
extern doublereal sopgb_(char *, integer *, integer *, integer *, integer
*, integer *);
static integer itran;
static char trans[1];
extern /* Subroutine */ int sgtsl_(integer *, real *, real *, real *,
real *, integer *);
static real s1, s2;
extern /* Subroutine */ int sgtsv_(integer *, integer *, real *, real *,
real *, real *, integer *, integer *);
static integer ic, im;
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int atimin_(char *, char *, integer *, char *,
logical *, integer *, integer *, ftnlen, ftnlen, ftnlen);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
extern /* Subroutine */ int stimmg_(integer *, integer *, integer *, real
*, integer *, integer *, integer *);
static logical timsub[4];
extern /* Subroutine */ int sprtbl_(char *, char *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, ftnlen, ftnlen), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *), sgttrs_(char *, integer *,
integer *, real *, real *, real *, real *, integer *, real *,
integer *, integer *);
static integer ldb, icl;
static real ops;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___27 = { 0, 0, 0, 0, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
STIMGT times SGTTRF, -TRS, -SV, and -SL.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix size M.
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.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) REAL
The minimum time a subroutine will be timed.
A (workspace) REAL array, dimension (NMAX*4)
where NMAX is the maximum value permitted for N.
B (workspace) REAL array, dimension (LDAMAX*NMAX)
IWORK (workspace) INTEGER array, dimension (NMAX)
RESLTS (output) REAL array, dimension
(LDR1,LDR2,LDR3,NSUBS+1)
The timing results for each subroutine over the relevant
values of N.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= 1.
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--mval;
--nsval;
--ldaval;
--a;
--b;
--iwork;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__4, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L180;
}
/* Check that N <= LDA for the input values. */
for (isub = 2; isub <= 4; ++isub) {
if (! timsub[isub - 1]) {
goto L10;
}
s_copy(cname, subnam_ref(0, isub), (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___8.ciunit = *nout;
s_wsfe(&io___8);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
timsub[isub - 1] = FALSE_;
}
L10:
;
}
/* Do for each value of M: */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
n = max(m,1);
/* Time SGTTRF */
if (timsub[0]) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
ic = 0;
s1 = second_();
L20:
sgttrf_(&m, &a[1], &a[n], &a[n * 2], &a[n * 3 - 2], &iwork[1], &
info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
goto L20;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L30:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
goto L30;
}
time = (time - untime) / (real) ic;
ops = sopgb_("SGTTRF", &m, &m, &c__1, &c__1, &iwork[1])
;
reslts_ref(1, im, 1, 1) = smflop_(&ops, &time, &info);
} else if (timsub[1]) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
}
/* Generate another matrix and factor it using SGTTRF so
that the factored form can be used in timing the other
routines. */
if (ic != 1) {
sgttrf_(&m, &a[1], &a[n], &a[n * 2], &a[n * 3 - 2], &iwork[1], &
info);
}
/* Time SGTTRS */
if (timsub[1]) {
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
ldb = ldaval[ilda];
i__3 = *nns;
for (i__ = 1; i__ <= i__3; ++i__) {
nrhs = nsval[i__];
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L40:
sgttrs_(trans, &m, &nrhs, &a[1], &a[n], &a[n * 2], &a[
n * 3 - 2], &iwork[1], &b[1], &ldb, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L40;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L50:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L50;
}
time = (time - untime) / (real) ic;
ops = sopgb_("SGTTRS", &m, &nrhs, &c__0, &c__0, &
iwork[1]);
if (itran == 1) {
reslts_ref(i__, im, ilda, 2) = smflop_(&ops, &
time, &info);
} else {
reslts_ref(i__, im, ilda, 5) = smflop_(&ops, &
time, &info);
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
}
if (timsub[2]) {
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
ldb = ldaval[ilda];
i__3 = *nns;
for (i__ = 1; i__ <= i__3; ++i__) {
nrhs = nsval[i__];
i__4 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__4, &c__0, &c__0);
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L90:
sgtsv_(&m, &nrhs, &a[1], &a[n], &a[n * 2], &b[1], &ldb, &
info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__4 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__4, &c__0, &c__0);
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L90;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L100:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__4 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__4, &c__0, &c__0);
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L100;
}
time = (time - untime) / (real) ic;
ops = sopgb_("SGTSV ", &m, &nrhs, &c__0, &c__0, &iwork[1]);
reslts_ref(i__, im, ilda, 3) = smflop_(&ops, &time, &info)
;
/* L110: */
}
/* L120: */
}
}
if (timsub[3]) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
stimmg_(&c__0, &m, &c__1, &b[1], &n, &c__0, &c__0);
ic = 0;
s1 = second_();
L130:
sgtsl_(&m, &a[1], &a[n], &a[n * 2], &b[1], &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
stimmg_(&c__0, &m, &c__1, &b[1], &ldb, &c__0, &c__0);
goto L130;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L140:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__2 = n * 3;
stimmg_(&c__12, &m, &m, &a[1], &i__2, &c__0, &c__0);
stimmg_(&c__0, &m, &c__1, &b[1], &ldb, &c__0, &c__0);
goto L140;
}
time = (time - untime) / (real) ic;
ops = sopgb_("SGTSV ", &m, &c__1, &c__0, &c__0, &iwork[1]);
reslts_ref(1, im, 1, 4) = smflop_(&ops, &time, &info);
}
/* L150: */
}
/* Print a table of results for each timed routine. */
for (isub = 1; isub <= 4; ++isub) {
if (! timsub[isub - 1]) {
goto L170;
}
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1 && (timsub[1] || timsub[2])) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L160: */
}
}
io___27.ciunit = *nout;
s_wsle(&io___27);
e_wsle();
if (isub == 1) {
sprtbl_(" ", "N", &c__1, laval, nm, &mval[1], &c__1, &reslts[
reslts_offset], ldr1, ldr2, nout, (ftnlen)1, (ftnlen)1);
} else if (isub == 2) {
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, "N", (ftnlen)1);
e_wsfe();
sprtbl_("NRHS", "N", nns, &nsval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, 2), ldr1, ldr2, nout, (ftnlen)4, (
ftnlen)1);
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, "T", (ftnlen)1);
e_wsfe();
sprtbl_("NRHS", "N", nns, &nsval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, 5), ldr1, ldr2, nout, (ftnlen)4, (
ftnlen)1);
} else if (isub == 3) {
sprtbl_("NRHS", "N", nns, &nsval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, 3), ldr1, ldr2, nout, (ftnlen)4, (
ftnlen)1);
} else if (isub == 4) {
sprtbl_(" ", "N", &c__1, laval, nm, &mval[1], &c__1, &reslts_ref(
1, 1, 1, 4), ldr1, ldr2, nout, (ftnlen)1, (ftnlen)1);
}
L170:
;
}
L180:
return 0;
/* End of STIMGT */
} /* stimgt_ */
/* Subroutine */ int sdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *af, real
*b, real *x, real *xact, real *work, real *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer k1, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode, koff, imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *), sscal_(integer *, real *,
real *, integer *);
integer nimat;
extern doublereal sget06_(real *, real *);
real anorm;
integer itran;
extern /* Subroutine */ int sgtt01_(integer *, real *, real *, real *,
real *, real *, real *, real *, integer *, real *, integer *,
real *, real *), sgtt02_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
real *), sgtt05_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *);
char trans[1];
integer izero, nerrs;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical zerot;
extern /* Subroutine */ int sgtsv_(integer *, integer *, real *, real *,
real *, real *, integer *, integer *), slatb4_(char *, integer *,
integer *, integer *, char *, integer *, integer *, real *,
integer *, real *, char *), aladhd_(
integer *, char *), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
real rcondc, rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
real rcondo, anormi;
extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
real *, real *, real *, real *, integer *, real *, real *,
integer *);
real ainvnm;
extern doublereal slangt_(char *, integer *, real *, real *, real *);
logical trfcon;
real anormo;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), slatms_(
integer *, integer *, char *, integer *, char *, real *, integer *
, real *, real *, integer *, integer *, char *, real *, integer *,
real *, integer *), slarnv_(integer *,
integer *, integer *, real *), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *);
real result[6];
extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, integer *), serrvx_(char *, integer *), sgtsvx_(char *, char
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, integer *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGT tests SGTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
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) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with SLATB4. */
slatb4_(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, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&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 SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&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) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = slangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = slangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use SGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use SGTTRS to solve for one column at a time of */
/* inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
sgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
slagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test SGTSV --- */
/* Solve the system using Gaussian elimination with */
/* partial pivoting. */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTSV ", (ftnlen)32, (ftnlen)
6);
sgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from SGTSV . */
if (info != izero) {
alaerh_(path, "SGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "SGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test SGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
af[i__] = 0.f;
/* L90: */
}
}
slaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SGTSVX. */
s_copy(srnamc_1.srnamt, "SGTSVX", (ftnlen)32, (ftnlen)6);
sgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &iwork[n + 1], &info);
/* Check the error code from SGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
sgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVGT */
} /* sdrvgt_ */
