/* Subroutine */ int cdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, complex *af,
complex *b, complex *x, complex *xact, complex *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
" ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
real r__1, r__2;
char ch__1[2];
/* 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 */
static char fact[1];
static real cond;
static integer mode, koff, imat, info;
static char path[3], dist[1], type__[1];
static integer nrun, i__, j, k, m, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4];
static real z__[3];
extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
complex *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *), cgtt02_(char *, integer *,
integer *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *);
static real rcond;
extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
static real anorm;
static integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cgtsv_(integer *, integer *, complex *,
complex *, complex *, complex *, integer *, integer *);
static char trans[1];
static integer izero, nerrs, k1;
static logical zerot;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix, nt;
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static real rcondc;
extern doublereal clangt_(char *, integer *, complex *, complex *,
complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), claset_(char *, integer *, integer
*, complex *, complex *, complex *, integer *);
static real rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real rcondo, anormi;
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cgttrf_(integer *, complex *, complex *,
complex *, complex *, integer *, integer *);
static logical trfcon;
static real anormo;
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cgtsvx_(char *, char *, integer *, integer *,
complex *, complex *, complex *, complex *, complex *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, real *, complex *, real *, integer *);
static integer lda;
/* 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.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVGT tests CGTSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX array, dimension (NMAX*4)
AF (workspace) COMPLEX array, dimension (NMAX*4)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number.
Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with
unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
clarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
csscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1], a[i__3].i = 0.f;
if (n > 1) {
a[1].r = z__[2], a[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1], a[i__3].i = 0.f;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = n - 1 + izero;
a[i__3].r = z__[1], a[i__3].i = 0.f;
i__3 = izero;
a[i__3].r = z__[2], a[i__3].i = 0.f;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1] = a[i__3].r;
i__3 = n;
a[i__3].r = 0.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2] = a[1].r;
a[1].r = 0.f, a[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0] = a[i__3].r;
i__3 = (n << 1) - 1;
z__[1] = a[i__3].r;
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = n - 1 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with
the value returned by CGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = clangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use CGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use CGTTRS to solve for one column at a time of
inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
&iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
clagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test CGTSV ---
Solve the system using Gaussian elimination with
partial pivoting. */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)6, (ftnlen)
6);
cgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from CGTSV . */
if (info != izero) {
alaerh_(path, "CGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test CGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
af[i__4].r = 0.f, af[i__4].i = 0.f;
/* L90: */
}
}
claset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CGTSVX. */
s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)6, (ftnlen)6);
cgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
cgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGT */
} /* cdrvgt_ */
/* Subroutine */ int cchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, complex *af, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real cond;
static integer mode, koff, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char norm[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer m, n;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4];
static complex z__[3];
extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
complex *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *), cgtt02_(char *, integer *,
integer *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *);
static real rcond;
extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
static real anorm;
static integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static char trans[1];
static integer izero, nerrs;
static logical zerot;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix;
extern /* Subroutine */ int cerrge_(char *, integer *);
static real rcondc;
extern doublereal clangt_(char *, integer *, complex *, complex *,
complex *);
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *), clacpy_(char *, integer *, integer
*, complex *, integer *, complex *, integer *), csscal_(
integer *, real *, complex *, integer *), cgtcon_(char *, integer
*, complex *, complex *, complex *, complex *, integer *, real *,
real *, complex *, integer *);
static real rcondi;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
static real rcondo;
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cgtrfs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, complex *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, complex *, real *, integer *), cgttrf_(integer *,
complex *, complex *, complex *, complex *, integer *, integer *);
static logical trfcon;
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
static real result[7];
static integer lda;
/* 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.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CCHKGT tests CGTTRF, -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) COMPLEX array, dimension (NMAX*4)
AF (workspace) COMPLEX array, dimension (NMAX*4)
B (workspace) COMPLEX array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) COMPLEX array, dimension (NMAX*NSMAX)
XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) REAL array, dimension
(max(NMAX)+2*NSMAX)
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrge_(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 CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number.
Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with
unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements whose real and
imaginary parts are from [-1,1]. */
i__3 = n + (m << 1);
clarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
csscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
if (n > 1) {
a[1].r = z__[2].r, a[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
i__3 = n - 1 + izero;
a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
i__3 = izero;
a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n;
a[i__3].r = 0.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2].r = a[1].r, z__[2].i = a[1].i;
a[1].r = 0.f, a[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
i__3 = (n << 1) - 1;
z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = n - 1 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
}
/* + TEST 1
Factor A as L*U and compute the ratio
norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)6, (ftnlen)6);
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from CGTTRF. */
if (info != izero) {
alaerh_(path, "CGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* 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 = clangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use CGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_(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 = scasum_(&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, "CGTCON", (ftnlen)6, (ftnlen)6);
cgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
info);
/* Check error code from CGTCON. */
if (info != 0) {
alaerh_(path, "CGTCON", &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) {
clarnv_(&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. */
clagtm_(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. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)6, (ftnlen)6);
cgttrs_(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 CGTTRS. */
if (info != 0) {
alaerh_(path, "CGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3
Check solution from generated exact solution. */
cget04_(&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, "CGTRFS", (ftnlen)6, (ftnlen)6);
cgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
nrhs << 1) + 1], &info);
/* Check error code from CGTRFS. */
if (info != 0) {
alaerh_(path, "CGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[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 CCHKGT */
} /* cchkgt_ */
/* Subroutine */ int cerrgt_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
complex b[2];
real d__[2];
complex e[2];
integer i__;
complex w[2], x[2];
char c2[2];
real r1[2], r2[2], df[2];
complex ef[2], dl[2];
integer ip[2];
complex du[2];
real rw[2];
complex du2[2], dlf[2], duf[2];
integer info;
real rcond, anorm;
extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
cgtcon_(char *, integer *, complex *, complex *, complex *,
complex *, integer *, real *, real *, complex *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), cptcon_(integer *, real *, complex *, real
*, real *, real *, integer *), cgtrfs_(char *, integer *, integer
*, complex *, complex *, complex *, complex *, complex *, complex
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, real *, integer *), cgttrf_(
integer *, complex *, complex *, complex *, complex *, integer *,
integer *), cptrfs_(char *, integer *, integer *, real *, complex
*, real *, complex *, complex *, integer *, complex *, integer *,
real *, real *, complex *, real *, integer *), cpttrf_(
integer *, real *, complex *, integer *), cgttrs_(char *, integer
*, integer *, complex *, complex *, complex *, complex *, integer
*, complex *, integer *, integer *), cpttrs_(char *,
integer *, integer *, real *, complex *, complex *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRGT tests the error exits for the COMPLEX 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);
for (i__ = 1; i__ <= 2; ++i__) {
d__[i__ - 1] = 1.f;
i__1 = i__ - 1;
e[i__1].r = 2.f, e[i__1].i = 0.f;
i__1 = i__ - 1;
dl[i__1].r = 3.f, dl[i__1].i = 0.f;
i__1 = i__ - 1;
du[i__1].r = 4.f, du[i__1].i = 0.f;
/* L10: */
}
anorm = 1.f;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GT")) {
/* Test error exits for the general tridiagonal routines. */
/* CGTTRF */
s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgttrf_(&c_n1, dl, e, du, du2, ip, &info);
chkxer_("CGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGTTRS */
s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgttrs_("/", &c__0, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgttrs_("N", &c_n1, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgttrs_("N", &c__0, &c_n1, dl, e, du, du2, ip, x, &c__1, &info);
chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cgttrs_("N", &c__2, &c__1, dl, e, du, du2, ip, x, &c__1, &info);
chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGTRFS */
s_copy(srnamc_1.srnamt, "CGTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgtrfs_("/", &c__0, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
x, &c__1, r1, r2, w, rw, &info);
chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgtrfs_("N", &c_n1, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
x, &c__1, r1, r2, w, rw, &info);
chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cgtrfs_("N", &c__0, &c_n1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
x, &c__1, r1, r2, w, rw, &info);
chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
x, &c__2, r1, r2, w, rw, &info);
chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__2,
x, &c__1, r1, r2, w, rw, &info);
chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CGTCON */
s_copy(srnamc_1.srnamt, "CGTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cgtcon_("/", &c__0, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cgtcon_("I", &c_n1, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
r__1 = -anorm;
cgtcon_("I", &c__0, dl, e, du, du2, ip, &r__1, &rcond, w, &info);
chkxer_("CGTCON", &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. */
/* CPTTRF */
s_copy(srnamc_1.srnamt, "CPTTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpttrf_(&c_n1, d__, e, &info);
chkxer_("CPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPTTRS */
s_copy(srnamc_1.srnamt, "CPTTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpttrs_("/", &c__1, &c__0, d__, e, x, &c__1, &info);
chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpttrs_("U", &c_n1, &c__0, d__, e, x, &c__1, &info);
chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpttrs_("U", &c__0, &c_n1, d__, e, x, &c__1, &info);
chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cpttrs_("U", &c__2, &c__1, d__, e, x, &c__1, &info);
chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPTRFS */
s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cptrfs_("/", &c__1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
w, rw, &info);
chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cptrfs_("U", &c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
w, rw, &info);
chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cptrfs_("U", &c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
w, rw, &info);
chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2,
w, rw, &info);
chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2,
w, rw, &info);
chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPTCON */
s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cptcon_(&c_n1, d__, e, &anorm, &rcond, rw, &info);
chkxer_("CPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
r__1 = -anorm;
cptcon_(&c__0, d__, e, &r__1, &rcond, rw, &info);
chkxer_("CPTCON", &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 CERRGT */
} /* cerrgt_ */
/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *d,
complex *du, complex *du2, integer *ipiv, real *anorm, real *rcond,
complex *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
=======
CGTCON estimates the reciprocal of the condition number of a complex
tridiagonal matrix A using the LU factorization as computed by
CGTTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by CGTTRF.
D (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) COMPLEX array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, 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.
ANORM (input) REAL
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer kase, kase1, i;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *), xerbla_(char *, integer *);
static real ainvnm;
static logical onenrm;
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
#define WORK(I) work[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define DU2(I) du2[(I)-1]
#define DU(I) du[(I)-1]
#define D(I) d[(I)-1]
#define DL(I) dl[(I)-1]
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
/* Check that D(1:N) is non-zero. */
i__1 = *n;
for (i = 1; i <= *n; ++i) {
i__2 = i;
if (D(i).r == 0.f && D(i).i == 0.f) {
return 0;
}
/* L10: */
}
ainvnm = 0.f;
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L20:
clacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(U)*inv(L). */
cgttrs_("No transpose", n, &c__1, &DL(1), &D(1), &DU(1), &DU2(1),
&IPIV(1), &WORK(1), n, info);
} else {
/* Multiply by inv(L')*inv(U'). */
cgttrs_("Conjugate transpose", n, &c__1, &DL(1), &D(1), &DU(1), &
DU2(1), &IPIV(1), &WORK(1), n, info);
}
goto L20;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
return 0;
/* End of CGTCON */
} /* cgtcon_ */
/* Subroutine */ int ctimgt_(char *line, integer *nm, integer *mval, integer *
nns, integer *nsval, integer *nlda, integer *ldaval, real *timmin,
complex *a, complex *b, integer *iwork, real *reslts, integer *ldr1,
integer *ldr2, integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*4] = "CGTTRF" "CGTTRS" "CGTSV " "CGTSL ";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(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_9998[] = "(\002 CGTTRS 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 *);
extern /* Subroutine */ int cgtsl_(integer *, complex *, complex *,
complex *, complex *, integer *), cgtsv_(integer *, integer *,
complex *, complex *, complex *, complex *, integer *, integer *);
static char trans[1];
static real s1, s2;
static integer ic, im;
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int ctimmg_(integer *, integer *, integer *,
complex *, integer *, integer *, integer *), atimin_(char *, char
*, integer *, char *, logical *, integer *, integer *, ftnlen,
ftnlen, ftnlen), cgttrf_(integer *, complex *, complex *, complex
*, complex *, integer *, integer *);
static integer itrans;
static real untime;
extern doublereal smflop_(real *, real *, integer *);
static logical timsub[4];
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *), sprtbl_(char *, char *, integer *, integer
*, integer *, integer *, integer *, real *, integer *, integer *,
integer *, ftnlen, ftnlen);
static integer ldb, icl;
static real ops;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, fmt_9999, 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_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9998, 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
=======
CTIMGT times CGTTRF, -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) COMPLEX array, dimension (NMAX*4)
where NMAX is the maximum value permitted for N.
B (workspace) COMPLEX 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, "Complex precision", (ftnlen)1, (ftnlen)17);
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 CGTTRF */
if (timsub[0]) {
i__2 = n * 3;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
ic = 0;
s1 = second_();
L20:
cgttrf_(&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;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
goto L20;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L30:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__2 = n * 3;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
goto L30;
}
time = (time - untime) / (real) ic;
ops = sopgb_("CGTTRF", &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;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
}
/* Generate another matrix and factor it using CGTTRF so
that the factored form can be used in timing the other
routines. */
if (ic != 1) {
cgttrf_(&m, &a[1], &a[n], &a[n * 2], &a[n * 3 - 2], &iwork[1], &
info);
}
/* Time CGTTRS */
if (timsub[1]) {
for (itrans = 1; itrans <= 3; ++itrans) {
*(unsigned char *)trans = *(unsigned char *)&transs[itrans -
1];
if (itrans == 1) {
isub = 2;
} else {
isub = itrans + 3;
}
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__];
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L40:
cgttrs_(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) {
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L40;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L50:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &
c__0);
goto L50;
}
time = (time - untime) / (real) ic;
ops = sopgb_("CGTTRS", &m, &nrhs, &c__0, &c__0, &
iwork[1]);
reslts_ref(i__, im, ilda, isub) = 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;
ctimmg_(&c__14, &m, &m, &a[1], &i__4, &c__0, &c__0);
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
ic = 0;
s1 = second_();
L90:
cgtsv_(&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;
ctimmg_(&c__14, &m, &m, &a[1], &i__4, &c__0, &c__0);
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L90;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L100:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__4 = n * 3;
ctimmg_(&c__14, &m, &m, &a[1], &i__4, &c__0, &c__0);
ctimmg_(&c__0, &m, &nrhs, &b[1], &ldb, &c__0, &c__0);
goto L100;
}
time = (time - untime) / (real) ic;
ops = sopgb_("CGTSV ", &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;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
ctimmg_(&c__0, &m, &c__1, &b[1], &n, &c__0, &c__0);
ic = 0;
s1 = second_();
L130:
cgtsl_(&m, &a[1], &a[n], &a[n * 2], &b[1], &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
i__2 = n * 3;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
ctimmg_(&c__0, &m, &c__1, &b[1], &ldb, &c__0, &c__0);
goto L130;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L140:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
i__2 = n * 3;
ctimmg_(&c__14, &m, &m, &a[1], &i__2, &c__0, &c__0);
ctimmg_(&c__0, &m, &c__1, &b[1], &ldb, &c__0, &c__0);
goto L140;
}
time = (time - untime) / (real) ic;
ops = sopgb_("CGTSV ", &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);
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, "C", (ftnlen)1);
e_wsfe();
sprtbl_("NRHS", "N", nns, &nsval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, 6), 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 CTIMGT */
} /* ctimgt_ */
/* Subroutine */ int cgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, complex *dl, complex *d__, complex *du, complex *dlf, complex *
df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *
ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
complex *work, real *rwork, 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
=======
CGTSVX uses the LU factorization to compute the solution to a complex
system of linear equations A * X = B, A**T * X = B, or A**H * 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)
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) COMPLEX array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) COMPLEX array, dimension (N)
The n diagonal elements of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input or output) COMPLEX 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 CGTTRF.
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) COMPLEX 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) COMPLEX 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) COMPLEX 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 CGTTRF.
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) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL 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.
=====================================================================
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 */
static char norm[1];
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern doublereal slamch_(char *), clangt_(char *, integer *,
complex *, complex *, complex *);
static logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), cgtcon_(char *,
integer *, complex *, complex *, complex *, complex *, integer *,
real *, real *, complex *, integer *), xerbla_(char *,
integer *), cgtrfs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, complex *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, complex *, real *, integer *), cgttrf_(integer *,
complex *, complex *, complex *, complex *, integer *, integer *);
static logical notran;
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
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;
--rwork;
/* 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_("CGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
ccopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
ccopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
i__1 = *n - 1;
ccopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
}
cgttrf_(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 = clangt_(norm, n, &dl[1], &d__[1], &du[1]);
/* Compute the reciprocal of the condition number of A. */
cgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[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. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cgttrs_(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. */
cgtrfs_(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], &rwork[1], info);
return 0;
/* End of CGTSVX */
} /* cgtsvx_ */
/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *
dl, complex *d__, complex *du, complex *dlf, complex *df, complex *
duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *
x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is tridiagonal, and provides
error bounds and backward error estimates for the solution.
Arguments
=========
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)
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) COMPLEX array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) COMPLEX array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by CGTTRF.
DF (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) COMPLEX array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, 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) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CGTTRS.
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 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) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (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 */
/* Table of constant values */
static integer c__1 = 1;
static real c_b18 = -1.f;
static real c_b19 = 1.f;
static complex c_b26 = {1.f,0.f};
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8, i__9;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer count;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *), clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static integer nz;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1];
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
static char transt[1];
static real lstres, eps;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
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;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTRFS", &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;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* 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 - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
clagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x_ref(1, j)
, ldx, &c_b19, &work[1], n);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
error bound. */
if (notran) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7))
+ (r__8 = r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = dl[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&du[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L30: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = dl[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__10)));
}
} else {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7))
+ (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = du[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&dl[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L40: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = du[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__10)));
}
}
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(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 (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L50: */
}
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. */
cgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
1], &work[1], n, info);
caxpy_(n, &c_b26, &work[1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(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(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L60: */
}
kase = 0;
L70:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
cgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L90: */
}
cgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L100: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L110: */
}
return 0;
/* End of CGTRFS */
} /* cgtrfs_ */
/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *
d__, complex *du, complex *du2, integer *ipiv, real *anorm, real *
rcond, complex *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer i__, kase, kase1;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *), xerbla_(char *, integer *);
real ainvnm;
logical onenrm;
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGTCON estimates the reciprocal of the condition number of a complex */
/* tridiagonal matrix A using the LU factorization as computed by */
/* CGTTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* DL (input) COMPLEX array, dimension (N-1) */
/* The (n-1) multipliers that define the matrix L from the */
/* LU factorization of A as computed by CGTTRF. */
/* D (input) COMPLEX array, dimension (N) */
/* The n diagonal elements of the upper triangular matrix U from */
/* the LU factorization of A. */
/* DU (input) COMPLEX array, dimension (N-1) */
/* The (n-1) elements of the first superdiagonal of U. */
/* DU2 (input) COMPLEX array, dimension (N-2) */
/* The (n-2) elements of the second superdiagonal of U. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, 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. */
/* ANORM (input) REAL */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
--work;
--ipiv;
--du2;
--du;
--d__;
--dl;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
/* Check that D(1:N) is non-zero. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) {
return 0;
}
/* L10: */
}
ainvnm = 0.f;
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L20:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(U)*inv(L). */
cgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
, &ipiv[1], &work[1], n, info);
} else {
/* Multiply by inv(L')*inv(U'). */
cgttrs_("Conjugate transpose", n, &c__1, &dl[1], &d__[1], &du[1],
&du2[1], &ipiv[1], &work[1], n, info);
}
goto L20;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
return 0;
/* End of CGTCON */
} /* cgtcon_ */
