/* 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 sdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
real *e, real *b, real *x, real *xact, real *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* 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', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 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 */
/* ======= */
/* SDRVPT tests SPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) REAL array, dimension (NMAX*2) */
/* 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)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PT", (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];
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 (n > 0 && ! dotype[imat]) {
goto L110;
}
/* 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) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &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 L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[i__] = a[ia];
e[i__] = a[ia + 1];
ia += 2;
/* L20: */
}
if (n > 0) {
d__[n] = a[ia];
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
slarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + dabs(e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
1], dabs(r__2));
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
dabs(r__3));
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
sscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1] = z__[2];
}
} else if (izero == n) {
e[n - 1] = z__[0];
d__[n] = z__[1];
} else {
e[izero - 1] = z__[0];
d__[izero] = z__[1];
e[izero] = z__[2];
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1];
e[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
z__[0] = e[n - 1];
e[n - 1] = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
z__[0] = e[izero - 1];
z__[2] = e[izero];
e[izero - 1] = 0.f;
e[izero] = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* 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;
/* L40: */
}
/* Set the right hand side. */
slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
&b[1], &lda);
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 SPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slanst_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use SPTTRS 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;
spttrs_(&n, &c__1, &d__[n + 1], &e[n + 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 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test SPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from SPTSV . */
if (info != izero) {
alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
1], &lda, &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 = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SPTSV ", (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;
}
/* L70: */
}
nrun += nt;
}
/* --- Test SPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
e[n + i__] = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SPTSVX. */
s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &info);
/* Check the error code from SPTSVX. */
if (info != izero) {
alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (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;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPT */
} /* sdrvpt_ */
/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e,
real *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int xerbla_(char *, integer *), spttrf_(
integer *, real *, real *, integer *), spttrs_(integer *, integer
*, real *, real *, real *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPTSV computes the solution to a real system of linear equations */
/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */
/* matrix, and X and B are N-by-NRHS matrices. */
/* A is factored as A = L*D*L**T, and the factored form of A is then */
/* used to solve the system of equations. */
/* Arguments */
/* ========= */
/* 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. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix */
/* A. On exit, the n diagonal elements of the diagonal matrix */
/* D from the factorization A = L*D*L**T. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix A. On exit, the (n-1) subdiagonal elements of the */
/* unit bidiagonal factor L from the L*D*L**T factorization of */
/* A. (E can also be regarded as the superdiagonal of the unit */
/* bidiagonal factor U from the U**T*D*U factorization of A.) */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the solution has not been */
/* computed. The factorization has not been completed */
/* unless i = N. */
/* ===================================================================== */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTSV ", &i__1);
return 0;
}
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
spttrf_(n, &d__[1], &e[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
spttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
}
return 0;
/* End of SPTSV */
} /* sptsv_ */
/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e,
real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real s, bi, cx, dx, ex;
integer ix, nz;
real eps, safe1, safe2;
integer count;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real lstres;
extern /* Subroutine */ int spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric positive definite */
/* and tridiagonal, and provides error bounds and backward error */
/* estimates for the solution. */
/* Arguments */
/* ========= */
/* 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. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input) REAL array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from the */
/* factorization computed by SPTTRF. */
/* EF (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
/* L from the factorization computed by SPTTRF. */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) REAL array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by SPTTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The 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). */
/* 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 (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
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;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X. Also compute */
/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
if (*n == 1) {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
work[*n + 1] = bi - dx;
work[1] = dabs(bi) + dabs(dx);
} else {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
ex = e[1] * x[j * x_dim1 + 2];
work[*n + 1] = bi - dx - ex;
work[1] = dabs(bi) + dabs(dx) + dabs(ex);
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
bi = b[i__ + j * b_dim1];
cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1];
dx = d__[i__] * x[i__ + j * x_dim1];
ex = e[i__] * x[i__ + 1 + j * x_dim1];
work[*n + i__] = bi - cx - dx - ex;
work[i__] = dabs(bi) + dabs(cx) + dabs(dx) + dabs(ex);
/* L30: */
}
bi = b[*n + j * b_dim1];
cx = e[*n - 1] * x[*n - 1 + j * x_dim1];
dx = d__[*n] * x[*n + j * x_dim1];
work[*n + *n] = bi - cx - dx;
work[*n] = dabs(bi) + dabs(cx) + dabs(dx);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__3);
}
/* L40: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
spttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info);
saxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L50: */
}
ix = isamax_(n, &work[1], &c__1);
ferr[j] = work[ix];
/* Estimate the norm of inv(A). */
/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
/* m(i,j) = abs(A(i,j)), i = j, */
/* m(i,j) = -abs(A(i,j)), i .ne. j, */
/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
/* Solve M(L) * x = e. */
work[1] = 1.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
work[i__] = work[i__ - 1] * (r__1 = ef[i__ - 1], dabs(r__1)) +
1.f;
/* L60: */
}
/* Solve D * M(L)' * x = b. */
work[*n] /= df[*n];
for (i__ = *n - 1; i__ >= 1; --i__) {
work[i__] = work[i__] / df[i__] + work[i__ + 1] * (r__1 = ef[i__],
dabs(r__1));
/* L70: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = isamax_(n, &work[1], &c__1);
ferr[j] *= (r__1 = work[ix], dabs(r__1));
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
lstres = dmax(r__2,r__3);
/* L80: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L90: */
}
return 0;
/* End of SPTRFS */
} /* sptrfs_ */
/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e,
real *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 25, 1997
Purpose
=======
SPTSV computes the solution to a real system of linear equations
A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
matrix, and X and B are N-by-NRHS matrices.
A is factored as A = L*D*L**T, and the factored form of A is then
used to solve the system of equations.
Arguments
=========
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.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the tridiagonal matrix
A. On exit, the n diagonal elements of the diagonal matrix
D from the factorization A = L*D*L**T.
E (input/output) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix A. On exit, the (n-1) subdiagonal elements of the
unit bidiagonal factor L from the L*D*L**T factorization of
A. (E can also be regarded as the superdiagonal of the unit
bidiagonal factor U from the U**T*D*U factorization of A.)
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the solution has not been
computed. The factorization has not been completed
unless i = N.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int xerbla_(char *, integer *), spttrf_(
integer *, real *, real *, integer *), spttrs_(integer *, integer
*, real *, real *, real *, integer *, integer *);
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTSV ", &i__1);
return 0;
}
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
spttrf_(n, &d__[1], &e[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
spttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
}
return 0;
/* End of SPTSV */
} /* sptsv_ */
/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d, real *e,
real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, 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
=======
SPTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric positive definite
and tridiagonal, and provides error bounds and backward error
estimates for the solution.
Arguments
=========
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.
D (input) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of the tridiagonal matrix A.
DF (input) REAL array, dimension (N)
The n diagonal elements of the diagonal matrix D from the
factorization computed by SPTTRF.
EF (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of the unit bidiagonal factor
L from the factorization computed by SPTTRF.
B (input) REAL array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) REAL array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by SPTTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The 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).
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 (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static real c_b11 = 1.f;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
static real safe1, safe2;
static integer i, j;
static real s;
static integer count;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
static real bi, cx, dx, ex;
static integer ix;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real lstres;
extern /* Subroutine */ int spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
static real eps;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define DF(I) df[(I)-1]
#define EF(I) ef[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.f;
BERR(j) = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X. Also compute
abs(A)*abs(x) + abs(b) for use in the backward error bound.
*/
if (*n == 1) {
bi = B(1,j);
dx = D(1) * X(1,j);
WORK(*n + 1) = bi - dx;
WORK(1) = dabs(bi) + dabs(dx);
} else {
bi = B(1,j);
dx = D(1) * X(1,j);
ex = E(1) * X(2,j);
WORK(*n + 1) = bi - dx - ex;
WORK(1) = dabs(bi) + dabs(dx) + dabs(ex);
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
bi = B(i,j);
cx = E(i - 1) * X(i-1,j);
dx = D(i) * X(i,j);
ex = E(i) * X(i+1,j);
WORK(*n + i) = bi - cx - dx - ex;
WORK(i) = dabs(bi) + dabs(cx) + dabs(dx) + dabs(ex);
/* L30: */
}
bi = B(*n,j);
cx = E(*n - 1) * X(*n-1,j);
dx = D(*n) * X(*n,j);
WORK(*n + *n) = bi - cx - dx;
WORK(*n) = dabs(bi) + dabs(cx) + dabs(dx);
}
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
s = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = WORK(*n + i), dabs(r__1)) / WORK(i);
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = WORK(*n + i), dabs(r__1)) + safe1) /
(WORK(i) + safe1);
s = dmax(r__2,r__3);
}
/* L40: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
spttrs_(n, &c__1, &DF(1), &EF(1), &WORK(*n + 1), n, info);
saxpy_(n, &c_b11, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (r__1 = WORK(*n + i), dabs(r__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (r__1 = WORK(*n + i), dabs(r__1)) + nz * eps * WORK(
i) + safe1;
}
/* L50: */
}
ix = isamax_(n, &WORK(1), &c__1);
FERR(j) = WORK(ix);
/* Estimate the norm of inv(A).
Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
m(i,j) = abs(A(i,j)), i = j,
m(i,j) = -abs(A(i,j)), i .ne. j,
and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
Solve M(L) * x = e. */
WORK(1) = 1.f;
i__2 = *n;
for (i = 2; i <= *n; ++i) {
WORK(i) = WORK(i - 1) * (r__1 = EF(i - 1), dabs(r__1)) + 1.f;
/* L60: */
}
/* Solve D * M(L)' * x = b. */
WORK(*n) /= DF(*n);
for (i = *n - 1; i >= 1; --i) {
WORK(i) = WORK(i) / DF(i) + WORK(i + 1) * (r__1 = EF(i), dabs(
r__1));
/* L70: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = isamax_(n, &WORK(1), &c__1);
FERR(j) *= (r__1 = WORK(ix), dabs(r__1));
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = X(i,j), dabs(r__1));
lstres = dmax(r__2,r__3);
/* L80: */
}
if (lstres != 0.f) {
FERR(j) /= lstres;
}
/* L90: */
}
return 0;
/* End of SPTRFS */
} /* sptrfs_ */
/* Subroutine */ int stimpt_(char *line, integer *nm, integer *mval, integer *
nns, integer *nsval, integer *nlda, integer *ldaval, real *timmin,
real *a, real *b, real *reslts, integer *ldr1, integer *ldr2, integer
*ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*4] = "SPTTRF" "SPTTRS" "SPTSV " "SPTSL ";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_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 sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
static real s1, s2;
extern /* Subroutine */ int sptsl_(integer *, real *, real *, real *),
sptsv_(integer *, integer *, 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), spttrf_(integer *, real *, real *,
integer *), spttrs_(integer *, integer *, real *, real *, real *,
integer *, integer *);
static integer ldb, icl;
static real ops;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___24 = { 0, 0, 0, 0, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,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
=======
STIMPT times SPTTRF, -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*2)
where NMAX is the maximum value permitted for N.
B (workspace) REAL array, dimension (LDAMAX*NMAX)
RESLTS (output) REAL array, dimension
(LDR1,LDR2,LDR3,NSUBS)
The timing results for each subroutine over the relevant
values of N.
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;
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, "PT", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__4, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L170;
}
/* 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___7.ciunit = *nout;
s_wsfe(&io___7);
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 SPTTRF */
if (timsub[0]) {
i__2 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__2, &c__0, &c__0);
ic = 0;
s1 = second_();
L20:
spttrf_(&m, &a[1], &a[n + 1], &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__2 = n << 1;
stimmg_(&c__13, &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 << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__2, &c__0, &c__0);
goto L30;
}
time = (time - untime) / (real) ic;
ops = sopla_("SPTTRF", &m, &c__0, &c__0, &c__0, &c__0);
reslts_ref(1, im, 1, 1) = smflop_(&ops, &time, &info);
} else {
ic = 0;
i__2 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__2, &c__0, &c__0);
}
/* Generate another matrix and factor it using SPTTRF so
that the factored form can be used in timing the other
routines. */
if (ic != 1) {
spttrf_(&m, &a[1], &a[n + 1], &info);
}
/* Time SPTTRS */
if (timsub[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:
spttrs_(&m, &nrhs, &a[1], &a[n + 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 = sopla_("SPTTRS", &m, &nrhs, &c__0, &c__0, &c__0);
reslts_ref(i__, im, ilda, 2) = smflop_(&ops, &time, &info)
;
/* L60: */
}
/* L70: */
}
}
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 << 1;
stimmg_(&c__13, &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_();
L80:
sptsv_(&m, &nrhs, &a[1], &a[n + 1], &b[1], &ldb, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__4 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__4, &c__0, &c__0);
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L80;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L90:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__4 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__4, &c__0, &c__0);
stimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L90;
}
time = (time - untime) / (real) ic;
ops = sopla_("SPTSV ", &m, &nrhs, &c__0, &c__0, &c__0);
reslts_ref(i__, im, ilda, 3) = smflop_(&ops, &time, &info)
;
/* L100: */
}
/* L110: */
}
}
if (timsub[3]) {
i__2 = n << 1;
stimmg_(&c__13, &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_();
L120:
sptsl_(&m, &a[1], &a[n + 1], &b[1]);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__2 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__2, &c__0, &c__0);
stimmg_(&c__0, &m, &c__1, &b[1], &n, &c__0, &c__0);
goto L120;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L130:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__2 = n << 1;
stimmg_(&c__13, &m, &m, &a[1], &i__2, &c__0, &c__0);
stimmg_(&c__0, &m, &c__1, &b[1], &n, &c__0, &c__0);
goto L130;
}
time = (time - untime) / (real) ic;
ops = sopla_("SPTSV ", &m, &c__1, &c__0, &c__0, &c__0);
reslts_ref(1, im, 1, 4) = smflop_(&ops, &time, &info);
}
/* L140: */
}
/* Print a table of results for each timed routine. */
for (isub = 1; isub <= 4; ++isub) {
if (! timsub[isub - 1]) {
goto L160;
}
io___22.ciunit = *nout;
s_wsfe(&io___22);
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___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L150: */
}
}
io___24.ciunit = *nout;
s_wsle(&io___24);
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) {
sprtbl_("NRHS", "N", nns, &nsval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, 2), 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);
}
L160:
;
}
L170:
return 0;
/* End of STIMPT */
} /* stimpt_ */
/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer
*ldx, real *rcond, real *ferr, real *berr, real *work, integer *info)
{
/* -- LAPACK 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
=======
SPTSVX uses the factorization A = L*D*L**T to compute the solution
to a real system of linear equations A*X = B, where A is an N-by-N
symmetric positive definite tridiagonal matrix 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 matrix A is factored as A = L*D*L**T, where L
is a unit lower bidiagonal matrix and D is diagonal. The
factorization can also be regarded as having the form
A = U**T*D*U.
2. If the leading i-by-i principal minor is not positive definite,
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': On entry, DF and EF contain the factored form of A.
D, E, DF, and EF will not be modified.
= 'N': The matrix A will be copied to DF and EF and
factored.
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 matrices B and X. NRHS >= 0.
D (input) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of the tridiagonal matrix 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 diagonal matrix D
from the L*D*L**T factorization of A.
If FACT = 'N', then DF is an output argument and on exit
contains the n diagonal elements of the diagonal matrix D
from the L*D*L**T factorization of A.
EF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then EF is an input argument and on entry
contains the (n-1) subdiagonal elements of the unit
bidiagonal factor L from the L*D*L**T factorization of A.
If FACT = 'N', then EF is an output argument and on exit
contains the (n-1) subdiagonal elements of the unit
bidiagonal factor L from the L*D*L**T factorization of A.
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 of 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 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 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).
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 (2*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: the leading minor of order i of A is
not positive definite, so the factorization
could not be completed, and the solution has not
been 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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* 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 */
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 *), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
);
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int sptcon_(integer *, real *, real *, real *,
real *, real *, integer *), sptrfs_(integer *, integer *, real *,
real *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, integer *), spttrf_(integer *, real *,
real *, integer *), spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
spttrf_(n, &df[1], &ef[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. */
anorm = slanst_("1", n, &d__[1], &e[1]);
/* Compute the reciprocal of the condition number of A. */
sptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
sptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
return 0;
/* End of SPTSVX */
} /* sptsvx_ */
/* Subroutine */
int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__, real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
extern real slamch_(char *);
logical nofact;
extern /* Subroutine */
int xerbla_(char *, integer *), slacpy_( char *, integer *, integer *, real *, integer *, real *, integer * );
extern real slanst_(char *, integer *, real *, real *);
extern /* Subroutine */
int sptcon_(integer *, real *, real *, real *, real *, real *, integer *), sptrfs_(integer *, integer *, real *, real *, real *, real *, real *, integer *, real *, integer *, real *, real *, real *, integer *), spttrf_(integer *, real *, real *, integer *), spttrs_(integer *, integer *, real *, real *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
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;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPTSVX", &i__1);
return 0;
}
if (nofact)
{
/* Compute the L*D*L**T (or U**T*D*U) factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1)
{
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
spttrf_(n, &df[1], &ef[1], info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = slanst_("1", n, &d__[1], &e[1]);
/* Compute the reciprocal of the condition number of A. */
sptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
sptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[ x_offset], ldx, &ferr[1], &berr[1], &work[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 SPTSVX */
}
