/* Subroutine */ int ddrvab_(logical *dotype, integer *nm, integer *mval,
integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
doublereal *a, doublereal *afac, doublereal *b, doublereal *x,
doublereal *work, doublereal *rwork, real *swork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 2006,2007,2008,2009 };
/* Format strings */
static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
"\002,i5,\002 instead of \002,i5,/\002 ==> M =\002,i5,\002, type"
" \002,i2)";
static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
"i5,\002 for M=\002,i5,\002, type \002,i2)";
static char fmt_8999[] = "(/1x,a3,\002: General dense matrices\002)";
static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
"lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
"\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
"\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
"mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
" column zero\002)";
static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
" norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
"* EPS ) > THRES if DGETRF\002)";
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,g1"
"2.5)";
static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
"tests failed to pass the threshold\002)";
static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
"assed the threshold (\002,i6,\002 tests run)\002)";
static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
/* System generated locals */
integer i__1, i__2, i__3;
cilist ci__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double sqrt(doublereal);
/* Local variables */
integer i__, m, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
char path[3], dist[1];
integer irhs, iter, nrhs;
char type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern /* Subroutine */ int dget08_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nimat;
doublereal anorm;
char trans[1];
integer izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dsgesv_(integer *, integer
*, doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, real *, integer *, integer
*);
doublereal result[1];
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9975, 0 };
static cilist io___34 = { 0, 0, 0, fmt_8999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_8979, 0 };
static cilist io___36 = { 0, 0, 0, fmt_8960, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVAB tests DSGESV */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(2*NMAX,2*NSMAX+NWORK)) */
/* SWORK (workspace) REAL array, dimension */
/* (NMAX*(NSMAX+NMAX)) */
/* IWORK (workspace) INTEGER array, dimension */
/* NMAX */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Variables .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--swork;
--rwork;
--work;
--x;
--b;
--afac;
--a;
--nsval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
kase = 0;
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
infoc_1.infot = 0;
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
n = m;
nimat = 11;
if (m <= 0 || 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;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L100;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode, &
cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__3 = m;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__3 = n - izero + 1;
dlaset_("Full", &m, &i__3, &c_b17, &c_b17, &a[ioff + 1], &
lda);
}
} else {
izero = 0;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
*(unsigned char *)trans = 'N';
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)6);
dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku, &nrhs, &a[
1], &lda, &x[1], &lda, &b[1], &lda, iseed, &info);
s_copy(srnamc_1.srnamt, "DSGESV", (ftnlen)6, (ftnlen)6);
++kase;
dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
dsgesv_(&n, &nrhs, &a[1], &lda, &iwork[1], &b[1], &lda, &x[1],
&lda, &work[1], &swork[1], &iter, &info);
if (iter < 0) {
dlacpy_("Full", &m, &n, &afac[1], &lda, &a[1], &lda);
}
/* Check error code from DSGESV. This should be the same as */
/* the one of DGETRF. */
if (info != izero) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
++nerrs;
if (info != izero && izero != 0) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, "DSGESV", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "DSGESV", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
e_wsfe();
}
}
/* Skip the remaining test if the matrix is singular. */
if (info != 0) {
goto L100;
}
/* Check the quality of the solution */
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
dget08_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
1], &lda, &rwork[1], result);
/* Check if the test passes the tesing. */
/* Print information about the tests that did not */
/* pass the testing. */
/* If iterative refinement has been used and claimed to */
/* be successful (ITER>0), we want */
/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
/* If double precision has been used (ITER<0), we want */
/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
/* (Cf. the linear solver testing routines) */
if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >= sqrt(
(doublereal) n) || iter < 0 && result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "DGE", (ftnlen)3);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Matrix types:' )";
s_wsfe(&ci__1);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Test ratios:' )";
s_wsfe(&ci__1);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Messages:' )";
s_wsfe(&ci__1);
e_wsfe();
}
io___37.ciunit = *nout;
s_wsfe(&io___37);
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 *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L60: */
}
L100:
;
}
/* L120: */
}
/* Print a summary of the results. */
if (nfail > 0) {
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "DSGESV", (ftnlen)6);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "DSGESV", (ftnlen)6);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
if (nerrs > 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
e_wsfe();
}
/* SUBNAM, INFO, INFOE, M, IMAT */
/* SUBNAM, INFO, M, IMAT */
return 0;
/* End of DDRVAB */
} /* ddrvab_ */
/* Subroutine */ int cchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
complex *ainv, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
real rcondc;
real cndnum;
real result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPO tests CPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* 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 */
/* (NMAX+2*NSMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PO", (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) {
cerrpo_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with CLATB4 and generate a test matrix */
/* with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
claipd_(&n, &a[1], &i__3, &c__0);
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
cpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from CPOTRF. */
if (info != izero) {
alaerh_(path, "CPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
cpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
cpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from CPOTRI. */
if (info != 0) {
alaerh_(path, "CPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
cpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)
6);
cpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from CPOTRS. */
if (info != 0) {
alaerh_(path, "CPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
cpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)
6);
cporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1],
&info);
/* Check error code from CPORFS. */
if (info != 0) {
alaerh_(path, "CPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = clanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
cpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &rwork[1], &info);
/* Check error code from CPOCON. */
if (info != 0) {
alaerh_(path, "CPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = sget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPO */
} /* cchkpo_ */
/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\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;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork;
extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zqrt11_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zqrt12_(integer *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *)
, dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zgeqpf_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal result[3];
extern /* Subroutine */ int zerrqp_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKQP tests ZGEQPF. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrqp_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L60;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
zlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
/* Compute the QR factorization with pivoting of A */
s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6);
zgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
&lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
tau[1], &iwork[1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = zqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
L60:
;
}
/* L70: */
}
/* L80: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of ZCHKQP */
return 0;
} /* zchkqp_ */
/* Subroutine */ int ddrvls_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nns, integer *nsval, integer *
nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
tsterr, doublereal *a, doublereal *copya, doublereal *b, doublereal *
copyb, doublereal *c__, doublereal *s, doublereal *copys, doublereal *
work, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
"=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
"\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal), log(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info;
static char path[3];
static integer rank, nrhs, nlvl, nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer m, n;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer nfail, iseed[4];
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer crank;
extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer irank;
static doublereal rcond;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer itran, mnmin, ncols;
static doublereal norma, normb;
extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dqrt14_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dqrt17_(char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static char trans[1];
static integer nerrs, itype;
extern /* Subroutine */ int dqrt13_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer lwork;
extern /* Subroutine */ int dqrt15_(integer *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dqrt16_(char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nrows, lwlsy, nb, im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iscale;
extern /* Subroutine */ int dgelsd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlacpy_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *), dgelss_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dgelsx_(integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *),
dgelsy_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), derrls_(char *, integer *),
xlaenv_(integer *, integer *);
static integer ldwork;
static doublereal result[18];
static integer lda, ldb, inb;
static doublereal eps;
static integer ins;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
January 3, 2000
Purpose
=======
DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX,
DGELSY and DGELSD.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
The matrix of type j is generated as follows:
j=1: A = U*D*V where U and V are random orthogonal matrices
and D has random entries (> 0.1) taken from a uniform
distribution (0,1). A is full rank.
j=2: The same of 1, but A is scaled up.
j=3: The same of 1, but A is scaled down.
j=4: A = U*D*V where U and V are random orthogonal matrices
and D has 3*min(M,N)/4 random entries (> 0.1) taken
from a uniform distribution (0,1) and the remaining
entries set to 0. A is rank-deficient.
j=5: The same of 4, but A is scaled up.
j=6: The same of 5, but A is scaled down.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
where MMAX is the maximum value of M in MVAL and NSMAX is the
maximum value of NRHS in NSVAL.
COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
C (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
WORK (workspace) DOUBLE PRECISION array,
dimension (MMAX*NMAX + 4*NMAX + MMAX).
IWORK (workspace) INTEGER array, dimension (15*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--copys;
--s;
--c__;
--copyb;
--b;
--copya;
--a;
--nxval;
--nbval;
--nsval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Threshold for rank estimation */
rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
/* Test the error exits */
if (*tsterr) {
derrls_(path, nout);
}
/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
alahd_(nout, path);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
xlaenv_(&c__9, &c__25);
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = max(1,m);
ldb = max(i__3,n);
i__3 = *nns;
for (ins = 1; ins <= i__3; ++ins) {
nrhs = nsval[ins];
/* Computing MAX
Computing MAX */
d__1 = 1., d__2 = (doublereal) mnmin;
i__4 = (integer) (log(max(d__1,d__2) / 26.) / log(2.)) + 1;
nlvl = max(i__4,0);
/* Computing MAX */
i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
i__4,i__5), i__5 = mnmin * 12 + mnmin * 50 + (mnmin <<
3) * nlvl + mnmin * nrhs + 676;
lwork = max(i__4,i__5);
for (irank = 1; irank <= 2; ++irank) {
for (iscale = 1; iscale <= 3; ++iscale) {
itype = (irank - 1) * 3 + iscale;
if (! dotype[itype]) {
goto L110;
}
if (irank == 1) {
/* Test DGELS
Generate a matrix of scaling type ISCALE */
dqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
iseed);
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)trans = 'N';
nrows = m;
ncols = n;
} else {
*(unsigned char *)trans = 'T';
nrows = n;
ncols = m;
}
ldwork = max(1,ncols);
/* Set up a consistent rhs */
if (ncols > 0) {
i__5 = ncols * nrhs;
dlarnv_(&c__2, iseed, &i__5, &work[1])
;
i__5 = ncols * nrhs;
d__1 = 1. / (doublereal) ncols;
dscal_(&i__5, &d__1, &work[1], &c__1);
}
dgemm_(trans, "No transpose", &nrows, &
nrhs, &ncols, &c_b24, ©a[1], &
lda, &work[1], &ldwork, &c_b25, &
b[1], &ldb)
;
dlacpy_("Full", &nrows, &nrhs, &b[1], &
ldb, ©b[1], &ldb);
/* Solve LS or overdetermined system */
if (m > 0 && n > 0) {
dlacpy_("Full", &m, &n, ©a[1], &
lda, &a[1], &lda);
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &b[1], &ldb);
}
s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)
6, (ftnlen)6);
dgels_(trans, &m, &n, &nrhs, &a[1], &lda,
&b[1], &ldb, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELS ", &info, &c__0,
trans, &m, &n, &nrhs, &c_n1, &
nb, &itype, &nfail, &nerrs,
nout);
}
/* Check correctness of results */
ldwork = max(1,nrows);
if (nrows > 0 && nrhs > 0) {
dlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &c__[1], &ldb);
}
dqrt16_(trans, &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &c__[1], &ldb, &
work[1], result);
if (itran == 1 && m >= n || itran == 2 &&
m < n) {
/* Solving LS system */
result[1] = dqrt17_(trans, &c__1, &m,
&n, &nrhs, ©a[1], &lda, &
b[1], &ldb, ©b[1], &ldb, &
c__[1], &work[1], &lwork);
} else {
/* Solving overdetermined system */
result[1] = dqrt14_(trans, &m, &n, &
nrhs, ©a[1], &lda, &b[1],
&ldb, &work[1], &lwork);
}
/* Print information about the tests that
did not pass the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itype, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 2;
/* L30: */
}
/* L40: */
}
}
/* Generate a matrix of scaling type ISCALE and rank
type IRANK. */
dqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
lda, ©b[1], &ldb, ©s[1], &rank, &
norma, &normb, iseed, &work[1], &lwork);
/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
Initialize vector IWORK. */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
iwork[j] = 0;
/* L50: */
}
ldwork = max(1,m);
/* Test DGELSX
DGELSX: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a complete
orthogonal factorization. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
ldb);
s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)6, (ftnlen)
6);
dgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &info);
if (info != 0) {
alaerh_(path, "DGELSX", &info, &c__0, " ", &m, &n,
&nrhs, &c_n1, &nb, &itype, &nfail, &
nerrs, nout);
}
/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS )
Test 3: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[2] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 4: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
&ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &work[1], &ldwork, &work[m *
nrhs + 1], &result[3]);
/* Test 5: Check norm of r'*A
workspace: NRHS*(M+N) */
result[4] = 0.;
if (m > crank) {
result[4] = dqrt17_("No transpose", &c__1, &m, &n,
&nrhs, ©a[1], &lda, &b[1], &ldb, &
copyb[1], &ldb, &c__[1], &work[1], &lwork);
}
/* Test 6: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[5] = 0.;
if (n > crank) {
result[5] = dqrt14_("No transpose", &m, &n, &nrhs,
©a[1], &lda, &b[1], &ldb, &work[1], &
lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 3; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 4;
/* Loop for testing different block sizes. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
/* Test DGELSY
DGELSY: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the rank-revealing orthogonal
factorization.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L70: */
}
/* Set LWLSY to the adequate value.
Computing MAX */
i__5 = 1, i__6 = mnmin + (n << 1) + nb * (n + 1),
i__5 = max(i__5,i__6), i__6 = (mnmin << 1)
+ nb * nrhs;
lwlsy = max(i__5,i__6);
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)6, (
ftnlen)6);
dgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &
lwlsy, &info);
if (info != 0) {
alaerh_(path, "DGELSY", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 7: Compute relative error in svd
workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[6] = dqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork);
/* Test 8: Compute error in solution
workspace: M*NRHS + M */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[7]);
/* Test 9: Check norm of r'*A
workspace: NRHS*(M+N) */
result[8] = 0.;
if (m > crank) {
result[8] = dqrt17_("No transpose", &c__1, &m,
&n, &nrhs, ©a[1], &lda, &b[1], &
ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 10: Check if x is in the rowspace of A
workspace: (M+NRHS)*(N+2) */
result[9] = 0.;
if (n > crank) {
result[9] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSS
DGELSS: Compute the minimum-norm solution X
to min( norm( A * X - B ) )
using the SVD. */
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)6, (
ftnlen)6);
dgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "DGELSS", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 3*min(m,n) +
max(2*min(m,n),nrhs,max(m,n))
Test 11: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[10] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[10] = 0.;
}
/* Test 12: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[11]);
/* Test 13: Check norm of r'*A */
result[12] = 0.;
if (m > crank) {
result[12] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 14: Check if x is in the rowspace of A */
result[13] = 0.;
if (n > crank) {
result[13] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test DGELSD
DGELSD: Compute the minimum-norm solution X
to min( norm( A * X - B ) ) using a
divide and conquer SVD.
Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L80: */
}
dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)6, (
ftnlen)6);
dgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
iwork[1], &info);
if (info != 0) {
alaerh_(path, "DGELSD", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 15: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
, &c__1);
result[14] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[14] = 0.;
}
/* Test 16: Compute error in solution */
dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
work[m * nrhs + 1], &result[15]);
/* Test 17: Check norm of r'*A */
result[16] = 0.;
if (m > crank) {
result[16] = dqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 18: Check if x is in the rowspace of A */
result[17] = 0.;
if (n > crank) {
result[17] = dqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Print information about the tests that did not
pass the threshold. */
for (k = 7; k <= 18; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun += 12;
/* L100: */
}
L110:
;
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVLS */
} /* ddrvls_ */
/* Subroutine */ int zchkhp_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
integer *nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *
ainv, doublecomplex *b, doublecomplex *x, doublecomplex *xact,
doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
doublereal rcond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zhpt01_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *);
integer iuplo, izero, nerrs;
extern /* Subroutine */ int zppt02_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *), zppt03_(char *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
char xtype[1];
extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
char packit[1];
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
logical trfcon;
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlarhs_(char *,
char *, char *, char *, integer *, integer *, integer *, integer *
, integer *, doublecomplex *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *,
integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublecomplex *,
integer *, doublecomplex *, integer *),
zhprfs_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *), zhptrf_(char *,
integer *, doublecomplex *, integer *, integer *);
doublereal result[8];
extern /* Subroutine */ int zhptri_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zhptrs_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *), zerrsy_(char *, integer *)
;
/* Fortran I/O blocks */
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKHP tests ZHPTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX*16 array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) COMPLEX*16 array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) COMPLEX*16 array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(2,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, */
/* dimension (NMAX+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "HP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrsy_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 10;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L160;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L160;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)packit = 'R';
}
/* Set up parameters with ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L150;
}
/* For types 3-6, zero one or more rows and columns of */
/* the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L60: */
}
ioff += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0., a[i__5].i = 0.;
/* L80: */
}
ioff = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
zlaipd_(&n, &a[1], &c__2, &c__1);
} else {
zlaipd_(&n, &a[1], &n, &c_n1);
}
/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
npp = n * (n + 1) / 2;
zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "ZHPTRF", (ftnlen)6, (ftnlen)6);
zhptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from ZHPTRF. */
if (info != k) {
alaerh_(path, "ZHPTRF", &info, &k, uplo, &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
zhpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
&rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse and compute the residual. */
if (! trfcon) {
zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "ZHPTRI", (ftnlen)6, (ftnlen)6);
zhptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
/* Check error code from ZHPTRI. */
if (info != 0) {
alaerh_(path, "ZHPTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
zppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
1], &rcondc, &result[1]);
nt = 2;
}
/* 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) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.;
goto L140;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZHPTRS", (ftnlen)6, (ftnlen)6);
zhptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from ZHPTRS. */
if (info != 0) {
alaerh_(path, "ZHPTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
zppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "ZHPRFS", (ftnlen)6, (ftnlen)6);
zhprfs_(uplo, &n, &nrhs, &a[1], &afac[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 ZHPRFS. */
if (info != 0) {
alaerh_(path, "ZHPRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[4]);
zppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
&xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "ZHPCON", (ftnlen)6, (ftnlen)6);
zhpcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
1], &info);
/* Check error code from ZHPCON. */
if (info != 0) {
alaerh_(path, "ZHPCON", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
/* L170: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKHP */
} /* zchkhp_ */
/* Subroutine */ int dchksy_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ioff, mode, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer n;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
static doublereal anorm;
extern /* Subroutine */ int dsyt01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
static integer iuplo, izero, i1, i2, nerrs, lwork;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static logical trfcon;
extern /* Subroutine */ int xlaenv_(integer *, integer *), dsycon_(char *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
derrsy_(char *, integer *), dsyrfs_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dsytrf_(char *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static doublereal result[8];
extern /* Subroutine */ int dsytri_(char *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *), dsytrs_(
char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
DCHKSY tests DSYTRF, -TRI, -TRS, -RFS, and -CON.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NBVAL)
The values of the blocksize NB.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(NMAX,2*NSMAX))
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrsy_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 10;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix
with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of
the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*D*L' or U*D*U' factorization of the
matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
lwork = max(2,nb) * lda;
s_copy(srnamc_1.srnamt, "DSYTRF", (ftnlen)6, (ftnlen)6);
dsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
lwork, &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from DSYTRF. */
if (info != k) {
alaerh_(path, "DSYTRF", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1
Reconstruct matrix from factors and compute residual. */
dsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
&ainv[1], &lda, &rwork[1], result);
nt = 1;
/* + TEST 2
Form the inverse and compute the residual. */
if (inb == 1 && ! trfcon) {
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DSYTRI", (ftnlen)6, (ftnlen)
6);
dsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
/* Check error code from DSYTRI. */
if (info != 0) {
alaerh_(path, "DSYTRI", &info, &c_n1, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
1], &lda, &rwork[1], &rcondc, &result[1]);
nt = 2;
}
/* Print information about the tests that did not pass
the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
/* Skip the other tests if this is not the first block
size. */
if (inb > 1) {
goto L150;
}
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.;
goto L140;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DSYTRS", (ftnlen)6, (ftnlen)
6);
dsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
x[1], &lda, &info);
/* Check error code from DSYTRS. */
if (info != 0) {
alaerh_(path, "DSYTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4
Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7
Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DSYRFS", (ftnlen)6, (ftnlen)
6);
dsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
, &rwork[nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check error code from DSYRFS. */
if (info != 0) {
alaerh_(path, "DSYRFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass
the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8
Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DSYCON", (ftnlen)6, (ftnlen)6);
dsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
rcond, &work[1], &iwork[n + 1], &info);
/* Check error code from DSYCON. */
if (info != 0) {
alaerh_(path, "DSYCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKSY */
} /* dchksy_ */
/* Subroutine */ int cchktb_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
nmax, complex *ab, complex *ainv, complex *b, complex *x, complex *
xact, complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002, K"
"D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
"i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )"
", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[3], a__2[4];
integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
char ch__1[3], ch__2[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer idiag;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
real scale;
integer nfail, iseed[4];
extern /* Subroutine */ int ctbt02_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, complex *, real *, real *), ctbt03_(char *, char *, char *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, complex *
, integer *, complex *, integer *, complex *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctbt05_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, complex *, integer *, real *, real *, real *
), ctbt06_(real *, real *, char *, char *,
integer *, integer *, complex *, integer *, real *, real *);
real rcond;
integer nimat;
real anorm;
integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), ctbsv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *);
char trans[1];
integer iuplo, nerrs;
char xtype[1];
integer nimat2;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
extern doublereal clantb_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
real rcondc;
extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
integer *, integer *, complex *, integer *, complex *, real *,
real *, integer *), clattb_(
integer *, char *, char *, char *, integer *, integer *, integer *
, complex *, integer *, complex *, complex *, real *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *), clarhs_(char
*, char *, char *, char *, integer *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *,
complex *, complex *, integer *);
real rcondi;
extern /* Subroutine */ int ctbcon_(char *, char *, char *, integer *,
integer *, complex *, integer *, real *, complex *, real *,
integer *);
extern doublereal clantr_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
real rcondo;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *), ctbrfs_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *, complex *, real *, integer *
);
real ainvnm;
extern /* Subroutine */ int cerrtr_(char *, integer *), ctbtrs_(
char *, char *, char *, integer *, integer *, integer *, complex *
, integer *, complex *, integer *, integer *);
real result[8];
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS. */
/* 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 column dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* 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. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. */
/* NMAX >= the maximum value of N in NVAL. */
/* AB (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* 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)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--ab;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TB", (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) {
cerrtr_(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);
*(unsigned char *)xtype = 'N';
nimat = 9;
nimat2 = 17;
if (n <= 0) {
nimat = 1;
nimat2 = 10;
}
/* Computing MIN */
i__2 = n + 1;
nk = min(i__2,4);
i__2 = nk;
for (ik = 1; ik <= i__2; ++ik) {
/* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
/* it easier to skip redundant values for small values of N. */
if (ik == 1) {
kd = 0;
} else if (ik == 2) {
kd = max(n,0);
} else if (ik == 3) {
kd = (n * 3 - 1) / 4;
} else if (ik == 4) {
kd = (n + 1) / 4;
}
ldab = kd + 1;
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L90;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Call CLATTB to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)6);
clattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd,
&ab[1], &ldab, &x[1], &work[1], &rwork[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
/* Form the inverse of A so we can get a good estimate */
/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
claset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
if (lsame_(uplo, "U")) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
ctbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
, &ldab, &ainv[(j - 1) * lda + 1], &c__1);
/* L20: */
}
} else {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = n - j + 1;
ctbsv_(uplo, "No transpose", diag, &i__5, &kd, &
ab[(j - 1) * ldab + 1], &ldab, &ainv[(j -
1) * lda + j], &c__1);
/* L30: */
}
}
/* Compute the 1-norm condition number of A. */
anorm = clantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
rwork[1]);
ainvnm = clantr_("1", uplo, diag, &n, &n, &ainv[1], &lda,
&rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anorm / ainvnm;
}
/* Compute the infinity-norm condition number of A. */
anorm = clantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
rwork[1]);
ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
&rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anorm / ainvnm;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 1 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
ftnlen)6);
clarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
idiag, &nrhs, &ab[1], &ldab, &xact[1], &
lda, &b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (
ftnlen)6);
ctbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
&ldab, &x[1], &lda, &info);
/* Check error code from CTBTRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = uplo;
i__6[1] = 1, a__1[1] = trans;
i__6[2] = 1, a__1[2] = diag;
s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
alaerh_(path, "CTBTRS", &info, &c__0, ch__1, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
ctbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
&ldab, &x[1], &lda, &b[1], &lda, &work[1]
, &rwork[1], result);
/* + TEST 2 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[1]);
/* + TESTS 3, 4, and 5 */
/* Use iterative refinement to improve the solution */
/* and compute error bounds. */
s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (
ftnlen)6);
ctbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
&ldab, &b[1], &lda, &x[1], &lda, &rwork[
1], &rwork[nrhs + 1], &work[1], &rwork[(
nrhs << 1) + 1], &info);
/* Check error code from CTBRFS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = uplo;
i__6[1] = 1, a__1[1] = trans;
i__6[2] = 1, a__1[2] = diag;
s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
alaerh_(path, "CTBRFS", &info, &c__0, ch__1, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
ctbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
&ldab, &b[1], &lda, &x[1], &lda, &xact[1]
, &lda, &rwork[1], &rwork[nrhs + 1], &
result[3]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 1; k <= 5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 5;
/* L50: */
}
/* L60: */
}
/* + TEST 6 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)
6);
ctbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
rcond, &work[1], &rwork[1], &info);
/* Check error code from CTBCON. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = norm;
i__6[1] = 1, a__1[1] = uplo;
i__6[2] = 1, a__1[2] = diag;
s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
alaerh_(path, "CTBCON", &info, &c__0, ch__1, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ctbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1],
&ldab, &rwork[1], &result[5]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "CTBCON", (ftnlen)6);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
++nrun;
/* L70: */
}
/* L80: */
}
L90:
;
}
/* Use pathological test matrices to test CLATBS. */
i__3 = nimat2;
for (imat = 10; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, and A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
/* Call CLATTB to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)
6);
clattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
1], &ldab, &x[1], &work[1], &rwork[1], &info);
/* + TEST 7 */
/* Solve the system op(A)*x = b */
s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)
6);
ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
clatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
ldab, &b[1], &scale, &rwork[1], &info);
/* Check error code from CLATBS. */
if (info != 0) {
/* Writing concatenation */
i__7[0] = 1, a__2[0] = uplo;
i__7[1] = 1, a__2[1] = trans;
i__7[2] = 1, a__2[2] = diag;
i__7[3] = 1, a__2[3] = "N";
s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
&x[1], &lda, &work[1], &result[6]);
/* + TEST 8 */
/* Solve op(A)*x = b again with NORMIN = 'Y'. */
ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
clatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
ldab, &b[1], &scale, &rwork[1], &info);
/* Check error code from CLATBS. */
if (info != 0) {
/* Writing concatenation */
i__7[0] = 1, a__2[0] = uplo;
i__7[1] = 1, a__2[1] = trans;
i__7[2] = 1, a__2[2] = diag;
i__7[3] = 1, a__2[3] = "Y";
s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
&x[1], &lda, &work[1], &result[7]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "CLATBS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "CLATBS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun += 2;
/* L100: */
}
/* L110: */
}
L120:
;
}
/* L130: */
}
/* L140: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKTB */
} /* cchktb_ */
/* Subroutine */ int zchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\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;
doublereal d__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, info;
static char path[3];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, nfail, iseed[4], imode, mnmin, nerrs, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt01_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt02_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztzrzf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
static integer lda;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 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
=======
ZCHKTZ tests ZTZRQF and ZTZRZF.
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.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) COMPLEX*16 array, dimension (MMAX)
WORK (workspace) COMPLEX*16 array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n;
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
/* Do for each type of singular value distribution.
0: zero matrix
1: one small singular value
2: exponential distribution */
mode = imode - 1;
/* Test ZTZRQF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L20: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRQF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6);
ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test ZTZRZF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRZF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6);
ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = zrzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass
the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
/* L50: */
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if ZCHKTZ */
return 0;
} /* zchktz_ */
/* 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 dchkge_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
"=\002,i4,\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,g1"
"2.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)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget01_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *), dget02_(char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dget03_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *), dget04_(integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dget07_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, logical *,
doublereal *, doublereal *);
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
char trans[1];
integer izero, nerrs;
doublereal dummy;
integer lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
doublereal rcondc;
extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
doublereal rcondi;
extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical trfcon;
doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(2*NMAX,2*NSMAX+NWORK)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (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 */
xlaenv_(&c__1, &c__1);
if (*tsterr) {
derrge_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
/* Do for each value of N in NVAL */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
*(unsigned char *)xtype = 'N';
nimat = 11;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L100;
}
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
} else {
i__4 = n - izero + 1;
dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
1], &lda);
}
} else {
izero = 0;
}
/* These lines, if used in place of the calls in the DO 60 */
/* loop, cause the code to bomb on a Sun SPARCstation. */
/* ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK ) */
/* ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK ) */
/* Do for each blocksize in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the matrix. */
dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
/* Check error code from DGETRF. */
if (info != izero) {
alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse if the factorization was successful */
/* and compute the residual. */
if (m == n && info == 0) {
dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
6);
nrhs = nsval[1];
lwork = *nmax * max(3,nrhs);
dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
lwork, &info);
/* Check error code from DGETRI. */
if (info != 0) {
alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
&c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
nout);
}
/* Compute the residual for the matrix times its */
/* inverse. Also compute the 1-norm condition number */
/* of A. */
dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondo, &result[1]);
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
/* Compute the infinity-norm condition number of A. */
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
nt = 2;
} else {
/* Do only the condition estimate if INFO > 0. */
trfcon = TRUE_;
anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
rcondo = 0.;
rcondi = 0.;
}
/* Print information about the tests so far that did not */
/* pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
/* Skip the remaining tests if this is not the first */
/* block size or if M .ne. N. Skip the solve tests if */
/* the matrix is singular. */
if (inb > 1 || m != n) {
goto L90;
}
if (trfcon) {
goto L70;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
ftnlen)6);
dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
&nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
ftnlen)6);
dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
1], &x[1], &lda, &info);
/* Check error code from DGETRS. */
if (info != 0) {
alaerh_(path, "DGETRS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the */
/* solution. */
s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
ftnlen)6);
dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
lda, &iwork[1], &b[1], &lda, &x[1], &lda,
&rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[n + 1], &info);
/* Check error code from DGERFS. */
if (info != 0) {
alaerh_(path, "DGERFS", &info, &c__0, trans, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &c_true, &rwork[nrhs + 1], &result[5]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 5;
/* L50: */
}
/* L60: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L70:
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
anorm = anormo;
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
anorm = anormi;
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
6);
dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
work[1], &iwork[n + 1], &info);
/* Check error code from DGECON. */
if (info != 0) {
alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
dummy = rcond;
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
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__8, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L80: */
}
L90:
;
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKGE */
} /* dchkge_ */
/* Subroutine */ int dchkq3_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, doublereal *thresh, doublereal *a, doublereal *copya,
doublereal *s, doublereal *copys, doublereal *tau, doublereal *work,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 M =\002,i5,\002, N =\002,i5,\002, "
"NB =\002,i4,\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, i__5;
doublereal d__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, info;
static char path[3];
static integer ilow, nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, ihigh, nfail, iseed[4], imode;
extern doublereal dqpt01_(integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dqrt11_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dqrt12_(integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static integer mnmin;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static integer istep, nerrs, lwork;
extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *);
static integer nb, im, in;
extern doublereal dlamch_(char *);
static integer lw;
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *);
static integer nx;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), dlatms_(integer *,
integer *, char *, integer *, char *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, char *,
doublereal *, integer *, doublereal *, integer *), xlaenv_(integer *, integer *);
static doublereal result[3];
static integer lda, inb;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___28 = { 0, 0, 0, fmt_9999, 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
=======
DCHKQ3 tests DGEQP3.
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.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) DOUBLE PRECISION array, dimension (MMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L70;
}
/* Do for each type of matrix
1: zero matrix
2: one small singular value
3: geometric distribution of singular values
4: first n/2 columns fixed
5: last n/2 columns fixed
6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
dlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Get a working copy of COPYA into A and a copy of
vector IWORK. */
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
/* Compute the QR factorization with pivoting of A
Computing MAX */
i__3 = 1, i__5 = (n << 1) + nb * (n + 1);
lw = max(i__3,i__5);
/* Compute the QP3 factorization of A */
s_copy(srnamc_1.srnamt, "DGEQP3", (ftnlen)6, (ftnlen)6);
dgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
work[1], &lw, &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A*P - Q*R ) */
result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
work[1], &lwork);
/* Print information about the tests that did not pass
the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "DGEQP3", (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
/* L60: */
}
L70:
;
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of DCHKQ3 */
return 0;
} /* dchkq3_ */
/* Subroutine */ int dchkpp_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
integer *nmax, doublereal *a, doublereal *afac, doublereal *ainv,
doublereal *b, doublereal *x, doublereal *xact, doublereal *work,
doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char packs[1*2] = "C" "R";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
integer nimat;
extern /* Subroutine */ int dppt01_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *), dppt02_(char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *),
dppt03_(char *, integer *, doublereal *, doublereal *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dppcon_(char *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), derrpo_(char *, integer *), dpprfs_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dpptrf_(char *, integer *, doublereal *, integer *),
dpptri_(char *, integer *, doublereal *, integer *),
dpptrs_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPP tests DPPTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L100;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Compute the L*L' or U'*U factorization of the matrix. */
npp = n * (n + 1) / 2;
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
dpptrf_(uplo, &n, &afac[1], &info);
/* Check error code from DPPTRF. */
if (info != izero) {
alaerh_(path, "DPPTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
dppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
dpptri_(uplo, &n, &ainv[1], &info);
/* Check error code from DPPTRI. */
if (info != 0) {
alaerh_(path, "DPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
dppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
&rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
dpptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
/* Check error code from DPPTRS. */
if (info != 0) {
alaerh_(path, "DPPTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
dpprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPPRFS. */
if (info != 0) {
alaerh_(path, "DPPRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[4]);
dppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
&xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
dppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &iwork[
1], &info);
/* Check error code from DPPCON. */
if (info != 0) {
alaerh_(path, "DPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPP */
} /* dchkpp_ */
/* Subroutine */ int ddrvac_(logical *dotype, integer *nm, integer *mval,
integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
doublereal *a, doublereal *afac, doublereal *b, doublereal *x,
doublereal *work, doublereal *rwork, real *swork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
"\002,i5,\002 instead of \002,i5,/\002 ==> N =\002,i5,\002, type"
" \002,i2)";
static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
"i5,\002 for M=\002,i5,\002, type \002,i2)";
static char fmt_8999[] = "(/1x,a3,\002: positive definite dense matri"
"ces\002)";
static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
"lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
"\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
"\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
"mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
" column zero\002)";
static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
" norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
"* EPS ) > THRES if DPOTRF\002)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N =\002,i5,\002, NR"
"HS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12"
".5)";
static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
"tests failed to pass the threshold\002)";
static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
"assed the threshold (\002,i6,\002 tests run)\002)";
static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
/* System generated locals */
integer i__1, i__2, i__3;
cilist ci__1;
/* Local variables */
integer i__, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
char path[3], dist[1];
integer irhs, iter, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4], nimat;
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
doublereal cndnum;
doublereal result[1];
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9988, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9975, 0 };
static cilist io___35 = { 0, 0, 0, fmt_8999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_8979, 0 };
static cilist io___37 = { 0, 0, 0, fmt_8960, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* April 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVAC tests DSPOSV. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of N contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(2*NMAX,2*NSMAX+NWORK)) */
/* SWORK (workspace) REAL array, dimension */
/* (NMAX*(NSMAX+NMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Variables .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--swork;
--rwork;
--work;
--x;
--b;
--afac;
--a;
--nsval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
kase = 0;
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
infoc_1.infot = 0;
/* Do for each value of N in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
n = mval[im];
lda = max(n,1);
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
a[1], &lda, &x[1], &lda, &b[1], &lda, iseed, &
info);
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
s_copy(srnamc_1.srnamt, "DSPOSV ", (ftnlen)32, (ftnlen)7);
++kase;
dlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
dsposv_(uplo, &n, &nrhs, &afac[1], &lda, &b[1], &lda, &x[
1], &lda, &work[1], &swork[1], &iter, &info);
if (iter < 0) {
dlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
}
/* Check error code from DSPOSV . */
if (info != izero) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
++nerrs;
if (info != izero && izero != 0) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
e_wsfe();
} else {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
e_wsfe();
}
}
/* Skip the remaining test if the matrix is singular. */
if (info != 0) {
goto L110;
}
/* Check the quality of the solution */
dlacpy_("All", &n, &nrhs, &b[1], &lda, &work[1], &lda);
dpot06_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
1], &lda, &rwork[1], result);
/* Check if the test passes the tesing. */
/* Print information about the tests that did not */
/* pass the testing. */
/* If iterative refinement has been used and claimed to */
/* be successful (ITER>0), we want */
/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
/* If double precision has been used (ITER<0), we want */
/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
/* (Cf. the linear solver testing routines) */
if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >=
sqrt((doublereal) n) || iter < 0 && result[0] >= *
thresh) {
if (nfail == 0 && nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "DPO", (ftnlen)3);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Matrix types:' )";
s_wsfe(&ci__1);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Test ratios:' )";
s_wsfe(&ci__1);
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
e_wsfe();
ci__1.cierr = 0;
ci__1.ciunit = *nout;
ci__1.cifmt = "( ' Messages:' )";
s_wsfe(&ci__1);
e_wsfe();
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L60: */
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* L130: */
/* Print a summary of the results. */
if (nfail > 0) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "DSPOSV", (ftnlen)6);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
if (nerrs > 0) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
e_wsfe();
}
/* SUBNAM, INFO, INFOE, N, IMAT */
/* SUBNAM, INFO, N, IMAT */
return 0;
/* End of DDRVAC */
} /* ddrvac_ */
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
",\002, ratio= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
"2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
") = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ldab, ioff, mode, koff, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, n;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dpbt01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dpbt02_(char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *),
dpbt05_(char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
static integer kdval[4];
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer iuplo, izero, i1, i2, nerrs;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer kd, nb, in, kl;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iw, ku;
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dpbcon_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static doublereal rcondc;
static char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dpbrfs_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dpbtrf_(char *,
integer *, integer *, doublereal *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
static doublereal ainvnm;
extern /* Subroutine */ int derrpo_(char *, integer *), dpbtrs_(
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), xlaenv_(integer *,
integer *);
static doublereal result[7];
static integer lda, ikd, inb, nkd;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
DCHKPB tests DPBTRF, -TRS, -RFS, and -CON.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NBVAL)
The values of the blocksize NB.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(NMAX,2*NSMAX))
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
kdval[0] = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations.
Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
makes it easier to skip redundant values for small values
of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
*(unsigned char *)packit = 'Q';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L60;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L60;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with DLATB4 and generate a test
matrix with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)
6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L60;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type
2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix
to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the band
matrix. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
ldab);
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)6, (ftnlen)
6);
dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Check error code from DPBTRF. */
if (info != izero) {
alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
nout);
goto L50;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L50;
}
/* + TEST 1
Reconstruct matrix from factors and compute
residual. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
&ldab);
dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
&rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Only do other tests if this is the first blocksize. */
if (inb > 1) {
goto L50;
}
/* Form the inverse of A so we can get a good estimate
of RCONDC = 1/(norm(A) * norm(inv(A))). */
dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (ftnlen)
6);
dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
&lda, &info);
/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
rwork[1]);
ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 2
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
&nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (
ftnlen)6);
dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
1], &lda, &info);
/* Check error code from DPBTRS. */
if (info != 0) {
alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3
Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6
Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)6, (
ftnlen)6);
dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
1], &ldab, &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPBRFS. */
if (info != 0) {
alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
&lda, &x[1], &lda, &xact[1], &lda, &
rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not
pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += 5;
/* L40: */
}
/* + TEST 7
Get an estimate of RCOND = 1/CNDNUM. */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)6, (ftnlen)
6);
dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
rcond, &work[1], &iwork[1], &info);
/* Check error code from DPBCON. */
if (info != 0) {
alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L50:
;
}
L60:
;
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPB */
} /* dchkpb_ */
/* Subroutine */ int zchkgb_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublecomplex *a, integer *la, doublecomplex *afac, integer *lafac,
doublecomplex *b, doublecomplex *x, doublecomplex *xact,
doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 *** In ZCHKGB, LA=\002,i5,\002 is too sm"
"all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
",i4,/\002 ==> Increase LA to at least \002,i5)";
static char fmt_9998[] = "(\002 *** In ZCHKGB, LAFAC=\002,i5,\002 is too"
" small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
"=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
"\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
",\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
"KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
"1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
"KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
nkl, iku, nku, ioff, mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, doublereal *);
integer nimat, klval[4];
extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer
*, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *), zgbt05_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer itran;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
integer kuval[4];
char trans[1];
integer izero, nerrs;
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
char xtype[1];
extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
integer ldafac;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
doublereal rcondc;
extern doublereal zlangb_(char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
doublereal rcondi;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum, anormi, rcondo;
extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublereal *, integer *);
doublereal ainvnm;
logical trfcon;
doublereal anormo;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *,
integer *), zgbrfs_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *, doublereal *, doublereal *, doublecomplex *,
doublereal *, integer *), zgbtrf_(integer *, integer *,
integer *, integer *, doublecomplex *, integer *, integer *,
integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zlarhs_(char *,
char *, char *, char *, integer *, integer *, integer *, integer *
, integer *, doublecomplex *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zgbtrs_(char *, integer *, integer *, integer *, integer
*, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *), zlatms_(integer *, integer *, char
*, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGB tests ZGBTRF, -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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (LA) */
/* LA (input) INTEGER */
/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
/* where KLMAX is the largest entry in the local array KLVAL, */
/* KUMAX is the largest entry in the local array KUVAL and */
/* NMAX is the largest entry in the input array NVAL. */
/* AFAC (workspace) COMPLEX*16 array, dimension (LAFAC) */
/* LAFAC (input) INTEGER */
/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
/* where KLMAX is the largest entry in the local array KLVAL, */
/* KUMAX is the largest entry in the local array KUVAL and */
/* NMAX is the largest entry in the input array NVAL. */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX,NMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--afac;
--a;
--nsval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
zerrge_(path, nout);
}
infoc_1.infot = 0;
/* Initialize the first value for the lower and upper bandwidths. */
klval[0] = 0;
kuval[0] = 0;
/* Do for each value of M in MVAL */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Set values to use for the lower bandwidth. */
klval[1] = m + (m + 1) / 4;
/* KLVAL( 2 ) = MAX( M-1, 0 ) */
klval[2] = (m * 3 - 1) / 4;
klval[3] = (m + 1) / 4;
/* Do for each value of N in NVAL */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
*(unsigned char *)xtype = 'N';
/* Set values to use for the upper bandwidth. */
kuval[1] = n + (n + 1) / 4;
/* KUVAL( 2 ) = MAX( N-1, 0 ) */
kuval[2] = (n * 3 - 1) / 4;
kuval[3] = (n + 1) / 4;
/* Set limits on the number of loop iterations. */
/* Computing MIN */
i__3 = m + 1;
nkl = min(i__3,4);
if (n == 0) {
nkl = 2;
}
/* Computing MIN */
i__3 = n + 1;
nku = min(i__3,4);
if (m == 0) {
nku = 2;
}
nimat = 8;
if (m <= 0 || n <= 0) {
nimat = 1;
}
i__3 = nkl;
for (ikl = 1; ikl <= i__3; ++ikl) {
/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
/* order makes it easier to skip redundant values for small */
/* values of M. */
kl = klval[ikl - 1];
i__4 = nku;
for (iku = 1; iku <= i__4; ++iku) {
/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
/* order makes it easier to skip redundant values for */
/* small values of N. */
ku = kuval[iku - 1];
/* Check that A and AFAC are big enough to generate this */
/* matrix. */
lda = kl + ku + 1;
ldafac = (kl << 1) + ku + 1;
if (lda * n > *la || ldafac * n > *lafac) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
if (n * (kl + ku + 1) > *la) {
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
);
i__5 = n * (kl + ku + 1);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
integer));
e_wsfe();
++nerrs;
}
if (n * ((kl << 1) + ku + 1) > *lafac) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
);
i__5 = n * ((kl << 1) + ku + 1);
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
integer));
e_wsfe();
++nerrs;
}
goto L130;
}
i__5 = nimat;
for (imat = 1; imat <= i__5; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 2, 3, or 4 if the matrix size is too */
/* small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L120;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with ZLATB4 and generate a */
/* test matrix with ZLATMS. */
zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
anorm, &mode, &cndnum, dist);
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - n;
koff = max(i__6,i__7);
i__6 = koff - 1;
for (i__ = 1; i__ <= i__6; ++i__) {
i__7 = i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L20: */
}
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (
ftnlen)6);
zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &
mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
koff], &lda, &work[1], &info);
/* Check the error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &info, &c__0, " ", &m,
&n, &kl, &ku, &c_n1, &imat, &nfail, &
nerrs, nout);
goto L120;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for */
/* type 2 by copying back the zeroed out column. */
i__6 = i2 - i1 + 1;
zcopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
}
/* For types 2, 3, and 4, zero one or more columns of */
/* the matrix to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = min(m,n);
} else {
izero = min(m,n) / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 4) {
/* Store the column to be zeroed out in B. */
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - izero;
i1 = max(i__6,i__7);
/* Computing MIN */
i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
izero);
i2 = min(i__6,i__7);
i__6 = i2 - i1 + 1;
zcopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
c__1);
i__6 = i2;
for (i__ = i1; i__ <= i__6; ++i__) {
i__7 = ioff + i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L30: */
}
} else {
i__6 = n;
for (j = izero; j <= i__6; ++j) {
/* Computing MAX */
i__7 = 1, i__8 = ku + 2 - j;
/* Computing MIN */
i__10 = kl + ku + 1, i__11 = ku + 1 + (m
- j);
i__9 = min(i__10,i__11);
for (i__ = max(i__7,i__8); i__ <= i__9;
++i__) {
i__7 = ioff + i__;
a[i__7].r = 0., a[i__7].i = 0.;
/* L40: */
}
ioff += lda;
/* L50: */
}
}
}
/* These lines, if used in place of the calls in the */
/* loop over INB, cause the code to bomb on a Sun */
/* SPARCstation. */
/* ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
/* ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
/* Do for each blocksize in NBVAL */
i__6 = *nnb;
for (inb = 1; inb <= i__6; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the LU factorization of the band matrix. */
if (m > 0 && n > 0) {
i__9 = kl + ku + 1;
zlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
kl + 1], &ldafac);
}
s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)6, (
ftnlen)6);
zgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
iwork[1], &info);
/* Check error code from ZGBTRF. */
if (info != izero) {
alaerh_(path, "ZGBTRF", &info, &izero, " ", &
m, &n, &kl, &ku, &nb, &imat, &nfail, &
nerrs, nout);
}
trfcon = FALSE_;
/* + TEST 1 */
/* Reconstruct matrix from factors and compute */
/* residual. */
zgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
ldafac, &iwork[1], &work[1], result);
/* Print information about the tests so far that */
/* did not pass the threshold. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Skip the remaining tests if this is not the */
/* first block size or if M .ne. N. */
if (inb > 1 || m != n) {
goto L110;
}
anormo = zlangb_("O", &n, &kl, &ku, &a[1], &lda, &
rwork[1]);
anormi = zlangb_("I", &n, &kl, &ku, &a[1], &lda, &
rwork[1]);
if (info == 0) {
/* Form the inverse of A so we can get a good */
/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
ldb = max(1,n);
zlaset_("Full", &n, &n, &c_b61, &c_b62, &work[
1], &ldb);
s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)6, (
ftnlen)6);
zgbtrs_("No transpose", &n, &kl, &ku, &n, &
afac[1], &ldafac, &iwork[1], &work[1],
&ldb, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlange_("O", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormo <= 0. || ainvnm <= 0.) {
rcondo = 1.;
} else {
rcondo = 1. / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of */
/* A. */
ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormi <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anormi / ainvnm;
}
} else {
/* Do only the condition estimate if INFO.NE.0. */
trfcon = TRUE_;
rcondo = 0.;
rcondi = 0.;
}
/* Skip the solve tests if the matrix is singular. */
if (trfcon) {
goto L90;
}
i__9 = *nns;
for (irhs = 1; irhs <= i__9; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char
*)&transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
/* + TEST 2: */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)
6, (ftnlen)6);
zlarhs_(path, xtype, " ", trans, &n, &n, &
kl, &ku, &nrhs, &a[1], &lda, &
xact[1], &ldb, &b[1], &ldb, iseed,
&info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
x[1], &ldb);
s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)
6, (ftnlen)6);
zgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
1], &ldafac, &iwork[1], &x[1], &
ldb, &info);
/* Check error code from ZGBTRS. */
if (info != 0) {
alaerh_(path, "ZGBTRS", &info, &c__0,
trans, &n, &n, &kl, &ku, &
c_n1, &imat, &nfail, &nerrs,
nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
work[1], &ldb);
zgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
a[1], &lda, &x[1], &ldb, &work[1],
&ldb, &result[1]);
/* + TEST 3: */
/* Check solution from generated exact */
/* solution. */
zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
&ldb, &rcondc, &result[2]);
/* + TESTS 4, 5, 6: */
/* Use iterative refinement to improve the */
/* solution. */
s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)
6, (ftnlen)6);
zgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
&lda, &afac[1], &ldafac, &iwork[
1], &b[1], &ldb, &x[1], &ldb, &
rwork[1], &rwork[nrhs + 1], &work[
1], &rwork[(nrhs << 1) + 1], &
info);
/* Check error code from ZGBRFS. */
if (info != 0) {
alaerh_(path, "ZGBRFS", &info, &c__0,
trans, &n, &n, &kl, &ku, &
nrhs, &imat, &nfail, &nerrs,
nout);
}
zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
&ldb, &rcondc, &result[3]);
zgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
&lda, &b[1], &ldb, &x[1], &ldb, &
xact[1], &ldb, &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___59.ciunit = *nout;
s_wsfe(&io___59);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 5;
/* L70: */
}
/* L80: */
}
/* + TEST 7: */
/* Get an estimate of RCOND = 1/CNDNUM. */
L90:
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
anorm = anormo;
rcondc = rcondo;
*(unsigned char *)norm = 'O';
} else {
anorm = anormi;
rcondc = rcondi;
*(unsigned char *)norm = 'I';
}
s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)6, (
ftnlen)6);
zgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
&iwork[1], &anorm, &rcond, &work[1],
&rwork[1], &info);
/* Check error code from ZGBCON. */
if (info != 0) {
alaerh_(path, "ZGBCON", &info, &c__0,
norm, &n, &n, &kl, &ku, &c_n1, &
imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did */
/* not pass the threshold. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L100: */
}
L110:
;
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKGB */
} /* zchkgb_ */
/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, real *d__, complex *e, complex *b, complex *x, complex *xact,
complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
"st \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"= \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
/* Local variables */
integer i__, j, k, n;
complex z__[3];
integer ia, in, kl, ku, ix, lda;
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[7];
/* Fortran I/O blocks */
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPT tests CPTTRF, -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*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* 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)) */
/* 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;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
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) {
cerrgt_(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 CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a Hermitian tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&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 CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &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__) {
i__4 = ia;
d__[i__] = a[i__4].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = ia;
d__[n] = a[i__3].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let E be complex, D real, with values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&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]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* 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);
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&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].r;
if (n > 1) {
e[1].r = z__[2].r, e[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = n;
d__[i__3] = z__[1].r;
} else {
i__3 = izero - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = izero;
d__[i__3] = z__[1].r;
i__3 = izero;
e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1].r = d__[1], z__[1].i = 0.f;
d__[1] = 0.f;
if (n > 1) {
z__[2].r = e[1].r, z__[2].i = e[1].i;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = n;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = izero;
z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
i__3 = izero - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = izero;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[izero] = 0.f;
}
}
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* + TEST 1 */
/* Factor A as L*D*L' and compute the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Check error code from CPTTRF. */
if (info != izero) {
alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
if (info > 0) {
rcondc = 0.f;
goto L100;
}
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
result);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___30.ciunit = *nout;
s_wsfe(&io___30);
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;
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
/* Compute norm(A). */
anorm = clanht_("1", &n, &d__[1], &e[1]);
/* Use CPTTRS 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;
/* L40: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L50: */
}
/* Computing MAX */
r__1 = 1.f, r__2 = anorm * ainvnm;
rcondc = 1.f / dmax(r__1,r__2);
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 (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L'. */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Set the right hand side. */
claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
&lda, &c_b49, &b[1], &lda);
/* + TEST 2 */
/* Solve A*x = b and compute the residual. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Check error code from CPTTRS. */
if (info != 0) {
alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &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, "CPTRFS", (ftnlen)32, (ftnlen)6);
cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
, &info);
/* Check error code from CPTRFS. */
if (info != 0) {
alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cptt05_(&n, &nrhs, &d__[1], &e[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___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
L100:
s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
info);
/* Check error code from CPTCON. */
if (info != 0) {
alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
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;
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPT */
} /* cchkpt_ */
/* Subroutine */ int dchktr_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *ainv, doublereal *b, doublereal *x, doublereal *xact,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
"i2,\002)= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
" \002,i2,\002, test(\002,i2,\002)= \002,g12"
".5)";
static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
"', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
"\002, test(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
char ch__1[2], ch__2[3], ch__3[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, lda, inb;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer idiag;
doublereal scale;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern logical lsame_(char *, char *);
doublereal rcond, anorm;
integer itran;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dtrt01_(char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *), dtrt02_(char *, char
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dtrt03_(char *, char *,
char *, integer *, integer *, doublereal *, integer *, doublereal
*, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dtrt05_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *), dtrt06_(
doublereal *, doublereal *, char *, char *, integer *, doublereal
*, integer *, doublereal *, doublereal *);
char trans[1];
integer iuplo, nerrs;
doublereal dummy;
char xtype[1];
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
doublereal rcondi;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
doublereal rcondo;
extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
doublereal ainvnm;
extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlattr_(
integer *, char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), dtrcon_(char *, char *, char *, integer *
, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *),
derrtr_(char *, integer *), dtrrfs_(char *, char *, char
*, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *),
dtrtri_(char *, char *, integer *, doublereal *, integer *,
integer *);
doublereal result[9];
extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS */
/* 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 column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. */
/* NMAX >= the maximum value of N in NVAL. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TR", (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) {
derrtr_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
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);
*(unsigned char *)xtype = 'N';
for (imat = 1; imat <= 10; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Call DLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "DLATTR", (ftnlen)6, (ftnlen)6);
dlattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
lda, &x[1], &work[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
i__2 = *nnb;
for (inb = 1; inb <= i__2; ++inb) {
/* Do for each blocksize in NBVAL */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* + TEST 1 */
/* Form the inverse of A. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DTRTRI", (ftnlen)6, (ftnlen)6);
dtrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
/* Check error code from DTRTRI. */
if (info != 0) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = uplo;
i__3[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
alaerh_(path, "DTRTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = dlantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
rwork[1]);
ainvnm = dlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
&rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondi = 1.;
} else {
rcondi = 1. / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times */
/* its inverse. Also compute the 1-norm condition number */
/* of A. */
dtrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
rcondo, &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___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Skip remaining tests if not the first block size. */
if (inb != 1) {
goto L60;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
&b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DTRTRS", (ftnlen)6, (
ftnlen)6);
dtrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &info);
/* Check error code from DTRTRS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "DTRTRS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
if (n > 0) {
dummy = a[1];
}
dtrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &b[1], &lda, &work[1], &
result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution */
/* and compute error bounds. */
s_copy(srnamc_1.srnamt, "DTRRFS", (ftnlen)6, (
ftnlen)6);
dtrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &iwork[1], &
info);
/* Check error code from DTRRFS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "DTRRFS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dtrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&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___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 5;
/* L30: */
}
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "DTRCON", (ftnlen)6, (ftnlen)
6);
dtrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
work[1], &iwork[1], &info);
/* Check error code from DTRCON. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = norm;
i__5[1] = 1, a__2[1] = uplo;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "DTRCON", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
dtrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
&rwork[1], &result[6]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* Use pathological test matrices to test DLATRS. */
for (imat = 11; imat <= 18; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, and A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
/* Call DLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "DLATTR", (ftnlen)6, (ftnlen)6);
dlattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
&x[1], &work[1], &info);
/* + TEST 8 */
/* Solve the system op(A)*x = b. */
s_copy(srnamc_1.srnamt, "DLATRS", (ftnlen)6, (ftnlen)6);
dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
dlatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
scale, &rwork[1], &info);
/* Check error code from DLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "N";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "DLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dtrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b101, &b[1], &lda, &x[1], &lda, &
work[1], &result[7]);
/* + TEST 9 */
/* Solve op(A)*X = b again with NORMIN = 'Y'. */
dcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
dlatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
, &scale, &rwork[1], &info);
/* Check error code from DLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "Y";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "DLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dtrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b101, &b[n + 1], &lda, &x[1], &lda,
&work[1], &result[8]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "DLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
if (result[8] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "DLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (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__9, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
nrun += 2;
/* L90: */
}
/* L100: */
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKTR */
} /* dchktr_ */
/* Subroutine */ int schklq_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
real *a, real *af, real *aq, real *al, real *ac, real *b, real *x,
real *xact, real *tau, real *work, real *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
imat, info;
char path[3];
integer kval[4];
char dist[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real anorm;
integer minmn;
integer nerrs, lwork;
real cndnum;
real result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKLQ tests SGELQF, SORGLQ and SORMLQ. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) REAL array, dimension (NMAX*NMAX) */
/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
/* AL (workspace) REAL array, dimension (NMAX*NMAX) */
/* AC (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* TAU (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
/* RWORK (workspace) REAL array, dimension (NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--al;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "LQ", (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) {
serrlq_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
lda = *nmax;
lwork = *nmax * max(*nmax,*nrhs);
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of N in NVAL. */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
minmn = min(m,n);
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L50;
}
/* Set up parameters with SLATB4 and generate a test matrix */
/* with SLATMS. */
slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L50;
}
/* Set some values for K: the first value must be MINMN, */
/* corresponding to the call of SLQT01; other values are */
/* used in the calls of SLQT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
for (i__ = 1; i__ <= 8; ++i__) {
result[i__ - 1] = 0.f;
}
nt = 2;
if (ik == 1) {
/* Test SGELQF */
slqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
if (! sgennd_(&m, &n, &af[1], &lda)) {
result[7] = *thresh * 2;
}
++nt;
} else if (m <= n) {
/* Test SORGLQ, using factorization */
/* returned by SLQT01 */
slqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
}
if (m >= k) {
/* Test SORMLQ, using factorization returned */
/* by SLQT01 */
slqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call SGELQS to solve a system */
/* with NRHS right hand sides and compute the */
/* residual. */
if (k == m && inb == 1) {
/* Generate a solution and set the right */
/* hand side. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
(ftnlen)6);
slarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
slacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "SGELQS", (ftnlen)32,
(ftnlen)6);
sgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from SGELQS. */
if (info != 0) {
alaerh_(path, "SGELQS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
sget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[1], &lda, &b[1], &lda, &rwork[
1], &result[6]);
++nt;
}
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (i__ = 1; i__ <= 8; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKLQ */
} /* schklq_ */
/* Subroutine */ int dchklq_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *al,
doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, imat, info;
static char path[3];
static integer kval[4];
static char dist[1], type__[1];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n;
extern /* Subroutine */ int dget02_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern /* Subroutine */ int dlqt01_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *), dlqt02_(
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *), dlqt03_(integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *);
static doublereal anorm;
static integer minmn, nerrs, lwork;
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer nb, ik, im, in, kl, nk;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt, nx;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dgelqs_(integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), derrlq_(char *, integer *), xlaenv_(integer *, integer *);
static doublereal result[7];
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 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
=======
DCHKLQ tests DGELQF, DORGLQ and DORMLQ.
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.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for M or N, used in dimensioning
the work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AL (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
TAU (workspace) DOUBLE PRECISION array, dimension (NMAX)
WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--al;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "LQ", (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) {
derrlq_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
lda = *nmax;
lwork = *nmax * max(*nmax,*nrhs);
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of N in NVAL. */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
minmn = min(m,n);
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L50;
}
/* Set up parameters with DLATB4 and generate a test matrix
with DLATMS. */
dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L50;
}
/* Set some values for K: the first value must be MINMN,
corresponding to the call of DLQT01; other values are
used in the calls of DLQT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
nt = 2;
if (ik == 1) {
/* Test DGELQF */
dlqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
} else if (m <= n) {
/* Test DORGLQ, using factorization
returned by DLQT01 */
dlqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
} else {
result[0] = 0.;
result[1] = 0.;
}
if (m >= k) {
/* Test DORMLQ, using factorization returned
by DLQT01 */
dlqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call DGELQS to solve a system
with NRHS right hand sides and compute the
residual. */
if (k == m && inb == 1) {
/* Generate a solution and set the right
hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "DGELQS", (ftnlen)6, (
ftnlen)6);
dgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from DGELQS. */
if (info != 0) {
alaerh_(path, "DGELQS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
dget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[1], &lda, &b[1], &lda, &rwork[
1], &result[6]);
++nt;
} else {
result[6] = 0.;
}
} else {
result[2] = 0.;
result[3] = 0.;
result[4] = 0.;
result[5] = 0.;
}
/* Print information about the tests that did not
pass the threshold. */
i__5 = nt;
for (i__ = 1; i__ <= i__5; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKLQ */
} /* dchklq_ */
/* Subroutine */ int schkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
real *af, real *b, real *x, real *xact, real *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer in, kl, ku, ix, lda;
real cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
real rcondc, rcondi, rcondo;
real ainvnm;
logical trfcon;
real result[7];
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKGT tests SGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from SGTTRF. */
if (info != izero) {
alaerh_(path, "SGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use SGTTRS to solve for one column at a time of inv(A) */
/* or inv(A^T), computing the maximum column sum as we */
/* go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.f;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
sgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
iwork[n + 1], &info);
/* Check error code from SGTCON. */
if (info != 0) {
alaerh_(path, "SGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
slagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
sgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from SGTTRS. */
if (info != 0) {
alaerh_(path, "SGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
sgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &iwork[n +
1], &info);
/* Check error code from SGTRFS. */
if (info != 0) {
alaerh_(path, "SGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
sgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKGT */
} /* schkgt_ */
/* Subroutine */ int dchkps_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nrank, integer *rankval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *perm, integer *piv, doublereal *work,
doublereal *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
" \002,i2,\002, Ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_dceiling(doublereal *), s_wsfe(cilist *), do_fio(integer *,
char *, ftnlen), e_wsfe(void);
/* Local variables */
integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
doublereal tol;
integer mode, imat, info, rank;
char path[3], dist[1], uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], irank, nimat;
extern /* Subroutine */ int dpst01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, integer *);
doublereal anorm;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int dlatb5_(char *, integer *, integer *, char *,
integer *, integer *, doublereal *, integer *, doublereal *, char
*), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatmt_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, integer *, char *, doublereal *, integer *,
doublereal *, integer *), xlaenv_(integer
*, integer *), derrps_(char *, integer *), dpstrf_(char *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *);
doublereal result;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPS tests DPSTRF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the block size NB. */
/* NRANK (input) INTEGER */
/* The number of values of RANK contained in the vector RANKVAL. */
/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the block size NB. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* PERM (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* PIV (workspace) INTEGER array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*3) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--piv;
--perm;
--afac;
--a;
--rankval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L100: */
}
/* Test the error exits */
if (*tsterr) {
derrps_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L140;
}
/* Do for each value of RANK in RANKVAL */
i__3 = *nrank;
for (irank = 1; irank <= i__3; ++irank) {
/* Only repeat test 3 to 5 for different ranks */
/* Other tests use full rank */
if ((imat < 3 || imat > 5) && irank > 1) {
goto L130;
}
d__1 = n * (doublereal) rankval[irank] / 100.;
rank = i_dceiling(&d__1);
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Set up parameters with DLATB5 and generate a test matrix */
/* with DLATMT. */
dlatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMT", (ftnlen)32, (ftnlen)6);
dlatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
lda, &work[1], &info);
/* Check error code from DLATMT. */
if (info != 0) {
alaerh_(path, "DLATMT", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L120;
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the pivoted L*L' or U'*U factorization */
/* of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)
6);
/* Use default tolerance */
tol = -1.;
dpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
&tol, &work[1], &info);
/* Check error code from DPSTRF. */
if (info < izero || info != izero && rank == n ||
info <= izero && rank < n) {
alaerh_(path, "DPSTRF", &info, &izero, uplo, &n, &
n, &c_n1, &c_n1, &nb, &imat, &nfail, &
nerrs, nout);
goto L110;
}
/* Skip the test if INFO is not 0. */
if (info != 0) {
goto L110;
}
/* Reconstruct matrix from factors and compute residual. */
/* PERM holds permuted L*L^T or U^T*U */
dpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
1], &lda, &piv[1], &rwork[1], &result, &
comprank);
/* Print information about the tests that did not pass */
/* the threshold or where computed rank was not RANK. */
if (n == 0) {
comprank = 0;
}
rankdiff = rank - comprank;
if (result >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L110:
;
}
L120:
;
}
L130:
;
}
L140:
;
}
/* L150: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPS */
} /* dchkps_ */
/* Subroutine */ int schktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, real *thresh, logical *tsterr, real *a,
real *copya, real *s, real *copys, real *tau, real *work, integer *
nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
real eps;
integer mode, info;
char path[3];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], imode, mnmin, nerrs;
extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
real *, integer *);
integer lwork;
extern doublereal srzt01_(integer *, integer *, real *, real *, integer *,
real *, real *, integer *), srzt02_(integer *, integer *, real *,
integer *, real *, real *, integer *), stzt01_(integer *,
integer *, real *, real *, integer *, real *, real *, integer *),
stzt02_(integer *, integer *, real *, integer *, real *, real *,
integer *);
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *), slaord_(char *, integer *, real *, integer
*), slacpy_(char *, integer *, integer *, real *, integer
*, real *, integer *), slaset_(char *, integer *, integer
*, real *, real *, real *, integer *), slatms_(integer *,
integer *, char *, integer *, char *, real *, integer *, real *,
real *, integer *, integer *, char *, real *, integer *, real *,
integer *);
real result[6];
extern /* Subroutine */ int serrtz_(char *, integer *), stzrqf_(
integer *, integer *, real *, integer *, real *, integer *),
stzrzf_(integer *, integer *, real *, integer *, real *, real *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKTZ tests STZRQF and STZRZF. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* 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 (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) REAL array, dimension (MMAX) */
/* WORK (workspace) REAL array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX) */
/* 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 */
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = slamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
serrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
i__4 = m * n + (mnmin << 1) + (n << 2);
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
if (! dotype[imode]) {
goto L50;
}
/* Do for each type of singular value distribution. */
/* 0: zero matrix */
/* 1: one small singular value */
/* 2: exponential distribution */
mode = imode - 1;
/* Test STZRQF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L20: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRQF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
stzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[1] = stzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = stzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test STZRZF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRZF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
stzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[4] = srzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = srzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (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;
}
/* L40: */
}
nrun += 6;
L50:
;
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if SCHKTZ */
return 0;
} /* schktz_ */
/* Subroutine */ int schktp_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
nmax, real *ap, real *ainvp, real *b, real *x, real *xact, real *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
"2.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
"\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
",i2,\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
"\002, test(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2[2], i__3, i__4[3], i__5[4];
char ch__1[2], ch__2[3], ch__3[4];
/* Local variables */
integer i__, k, n, in, lda, lap;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
integer idiag;
real scale;
integer nfail, iseed[4];
real rcond;
real anorm;
integer itran;
char trans[1];
integer iuplo, nerrs;
char xtype[1];
real rcondc, rcondi;
real rcondo, ainvnm;
real result[9];
/* Fortran I/O blocks */
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS */
/* 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 column dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* 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. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. NMAX >= the */
/* maximumm value of N in NVAL. */
/* AP (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINVP (workspace) REAL array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainvp;
--ap;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TP", (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) {
serrtr_(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);
lap = lda * (lda + 1) / 2;
*(unsigned char *)xtype = 'N';
for (imat = 1; imat <= 10; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L70;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Call SLATTP to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
slattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
&x[1], &work[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
/* + TEST 1 */
/* Form the inverse of A. */
if (n > 0) {
scopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
}
s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)32, (ftnlen)6);
stptri_(uplo, diag, &n, &ainvp[1], &info);
/* Check error code from STPTRI. */
if (info != 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = uplo;
i__2[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
alaerh_(path, "STPTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = slantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
ainvnm = slantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times its */
/* inverse. Also compute the 1-norm condition number of A. */
stpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &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___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (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__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
6);
slarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)32, (ftnlen)
6);
stptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
lda, &info);
/* Check error code from STPTRS. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = uplo;
i__4[1] = 1, a__2[1] = trans;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPTRS", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
stpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
lda, &b[1], &lda, &work[1], &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution and */
/* compute error bounds. */
s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)32, (ftnlen)
6);
stprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
&work[1], &iwork[1], &info);
/* Check error code from STPRFS. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = uplo;
i__4[1] = 1, a__2[1] = trans;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPRFS", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
stpt05_(uplo, trans, diag, &n, &nrhs, &ap[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___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&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;
}
/* L20: */
}
nrun += 5;
/* L30: */
}
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)32, (ftnlen)6);
stpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
iwork[1], &info);
/* Check error code from STPCON. */
if (info != 0) {
/* Writing concatenation */
i__4[0] = 1, a__2[0] = norm;
i__4[1] = 1, a__2[1] = uplo;
i__4[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
alaerh_(path, "STPCON", &info, &c__0, ch__2, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
, &result[6]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, "STPCON", (ftnlen)6);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (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: */
}
/* L60: */
}
L70:
;
}
/* Use pathological test matrices to test SLATPS. */
for (imat = 11; imat <= 18; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
/* Call SLATTP to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
slattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
, &work[1], &info);
/* + TEST 8 */
/* Solve the system op(A)*x = b. */
s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)32, (ftnlen)6);
scopy_(&n, &x[1], &c__1, &b[1], &c__1);
slatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
&rwork[1], &info);
/* Check error code from SLATPS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = uplo;
i__5[1] = 1, a__3[1] = trans;
i__5[2] = 1, a__3[2] = diag;
i__5[3] = 1, a__3[3] = "N";
s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
work[1], &result[7]);
/* + TEST 9 */
/* Solve op(A)*x = b again with NORMIN = 'Y'. */
scopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
slatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
scale, &rwork[1], &info);
/* Check error code from SLATPS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__3[0] = uplo;
i__5[1] = 1, a__3[1] = trans;
i__5[2] = 1, a__3[2] = diag;
i__5[3] = 1, a__3[3] = "Y";
s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
work[1], &result[8]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SLATPS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
if (result[8] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "SLATPS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (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__9, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
nrun += 2;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKTP */
} /* schktp_ */
/* Subroutine */ int cchkq3_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, real *thresh, complex *a, complex *copya, real *s, real *copys,
complex *tau, complex *work, real *rwork, integer *iwork, integer *
nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 M =\002,i5,\002, N =\002,i5,\002, "
"NB =\002,i4,\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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
real eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode;
extern doublereal cqpt01_(integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cqrt11_(integer *, integer *, complex *, integer *, complex *,
complex *, integer *), cqrt12_(integer *, integer *, complex *,
integer *, real *, complex *, integer *, real *);
integer mnmin;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
integer istep, nerrs, lwork;
extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
integer *, integer *, complex *, complex *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
*), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
xlaenv_(integer *, integer *);
real result[3];
/* Fortran I/O blocks */
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKQ3 tests CGEQP3. */
/* 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. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX array, dimension (MMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) REAL array, dimension (4*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = slamch_("Epsilon");
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L70;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
claset_("Full", &m, &n, &c_b1, &c_b1, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &r__1, &c_b15, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Save A and its singular values and a copy of */
/* vector IWORK. */
clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
/* Workspace needed. */
lw = nb * (n + 1);
s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)6, (ftnlen)6);
cgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
work[1], &lw, &rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
work[1], &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "CGEQP3", (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imode, (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;
}
/* L50: */
}
nrun += 3;
/* L60: */
}
L70:
;
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of CCHKQ3 */
return 0;
} /* cchkq3_ */
/* Subroutine */ int zdrvls_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nns, integer *nsval, integer *
nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
tsterr, doublecomplex *a, doublecomplex *copya, doublecomplex *b,
doublecomplex *copyb, doublecomplex *c__, doublereal *s, doublereal *
copys, doublecomplex *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
"=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
",\002, test(\002,i2,\002)=\002,g12.5)";
static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
"\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
doublereal eps;
integer ins, info;
char path[3];
integer rank, nrhs, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], crank, irank;
doublereal rcond;
extern doublereal dasum_(integer *, doublereal *, integer *);
integer itran, mnmin, ncols;
doublereal norma, normb;
extern /* Subroutine */ int zgels_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
zgemm_(char *, char *, integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
char trans[1];
integer nerrs, itype, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zqrt14_(char *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zqrt13_(integer *, integer *, integer *,
doublecomplex *, integer *, doublereal *, integer *), zqrt15_(
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublecomplex *, integer *);
integer nrows;
extern doublereal zqrt17_(char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer lwlsy;
extern /* Subroutine */ int zqrt16_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
integer iscale;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), zgelsd_(integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, integer *, doublecomplex *, integer *
, doublereal *, integer *, integer *), xlaenv_(integer *, integer
*);
integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zgelss_(integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, doublereal *, doublereal *,
integer *, doublecomplex *, integer *, doublereal *, integer *),
zgelsx_(integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, integer *, doublereal *, integer *,
doublecomplex *, doublereal *, integer *), zgelsy_(integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublereal *, integer *, doublecomplex *,
integer *, doublereal *, integer *);
doublereal result[18];
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *), zerrls_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVLS tests the least squares driver routines ZGELS, CGELSX, CGELSS, */
/* ZGELSY and CGELSD. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* The matrix of type j is generated as follows: */
/* j=1: A = U*D*V where U and V are random unitary matrices */
/* and D has random entries (> 0.1) taken from a uniform */
/* distribution (0,1). A is full rank. */
/* j=2: The same of 1, but A is scaled up. */
/* j=3: The same of 1, but A is scaled down. */
/* j=4: A = U*D*V where U and V are random unitary matrices */
/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
/* from a uniform distribution (0,1) and the remaining */
/* entries set to 0. A is rank-deficient. */
/* j=5: The same of 4, but A is scaled up. */
/* j=6: The same of 5, but A is scaled down. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
/* maximum value of NRHS in NSVAL. */
/* COPYB (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* C (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*NMAX-1) */
/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--copys;
--s;
--c__;
--copyb;
--b;
--copya;
--a;
--nxval;
--nbval;
--nsval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Threshold for rank estimation */
rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
/* Test the error exits */
xlaenv_(&c__9, &c__25);
if (*tsterr) {
zerrls_(path, nout);
}
/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
alahd_(nout, path);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = max(1,m);
ldb = max(i__3,n);
i__3 = *nns;
for (ins = 1; ins <= i__3; ++ins) {
nrhs = nsval[ins];
/* Computing MAX */
i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
i__4,i__5), i__5 = (n << 1) + m;
lwork = max(i__4,i__5);
for (irank = 1; irank <= 2; ++irank) {
for (iscale = 1; iscale <= 3; ++iscale) {
itype = (irank - 1) * 3 + iscale;
if (! dotype[itype]) {
goto L100;
}
if (irank == 1) {
/* Test ZGELS */
/* Generate a matrix of scaling type ISCALE */
zqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
iseed);
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)trans = 'N';
nrows = m;
ncols = n;
} else {
*(unsigned char *)trans = 'C';
nrows = n;
ncols = m;
}
ldwork = max(1,ncols);
/* Set up a consistent rhs */
if (ncols > 0) {
i__5 = ncols * nrhs;
zlarnv_(&c__2, iseed, &i__5, &work[1])
;
i__5 = ncols * nrhs;
d__1 = 1. / (doublereal) ncols;
zdscal_(&i__5, &d__1, &work[1], &c__1)
;
}
zgemm_(trans, "No transpose", &nrows, &
nrhs, &ncols, &c_b1, ©a[1], &
lda, &work[1], &ldwork, &c_b2, &b[
1], &ldb);
zlacpy_("Full", &nrows, &nrhs, &b[1], &
ldb, ©b[1], &ldb);
/* Solve LS or overdetermined system */
if (m > 0 && n > 0) {
zlacpy_("Full", &m, &n, ©a[1], &
lda, &a[1], &lda);
zlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &b[1], &ldb);
}
s_copy(srnamc_1.srnamt, "ZGELS ", (ftnlen)
6, (ftnlen)6);
zgels_(trans, &m, &n, &nrhs, &a[1], &lda,
&b[1], &ldb, &work[1], &lwork, &
info);
if (info != 0) {
alaerh_(path, "ZGELS ", &info, &c__0,
trans, &m, &n, &nrhs, &c_n1, &
nb, &itype, &nfail, &nerrs,
nout);
}
/* Check correctness of results */
ldwork = max(1,nrows);
if (nrows > 0 && nrhs > 0) {
zlacpy_("Full", &nrows, &nrhs, ©b[
1], &ldb, &c__[1], &ldb);
}
zqrt16_(trans, &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &c__[1], &ldb, &
rwork[1], result);
if (itran == 1 && m >= n || itran == 2 &&
m < n) {
/* Solving LS system */
result[1] = zqrt17_(trans, &c__1, &m,
&n, &nrhs, ©a[1], &lda, &
b[1], &ldb, ©b[1], &ldb, &
c__[1], &work[1], &lwork);
} else {
/* Solving overdetermined system */
result[1] = zqrt14_(trans, &m, &n, &
nrhs, ©a[1], &lda, &b[1],
&ldb, &work[1], &lwork);
}
/* Print information about the tests that */
/* did not pass the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nrhs, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itype, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 2;
/* L30: */
}
/* L40: */
}
}
/* Generate a matrix of scaling type ISCALE and rank */
/* type IRANK. */
zqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
lda, ©b[1], &ldb, ©s[1], &rank, &
norma, &normb, iseed, &work[1], &lwork);
/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
i__4 = n;
for (j = 1; j <= i__4; ++j) {
iwork[j] = 0;
/* L50: */
}
ldwork = max(1,m);
/* Test ZGELSX */
/* ZGELSX: Compute the minimum-norm solution X */
/* to min( norm( A * X - B ) ) */
/* using a complete orthogonal factorization. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
ldb);
s_copy(srnamc_1.srnamt, "ZGELSX", (ftnlen)6, (ftnlen)
6);
zgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &rwork[1],
&info);
if (info != 0) {
alaerh_(path, "ZGELSX", &info, &c__0, " ", &m, &n,
&nrhs, &c_n1, &nb, &itype, &nfail, &
nerrs, nout);
}
/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
/* Test 3: Compute relative error in svd */
/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[2] = zqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork, &rwork[1]);
/* Test 4: Compute error in solution */
/* workspace: M*NRHS + M */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
&ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
lda, &b[1], &ldb, &work[1], &ldwork, &rwork[1]
, &result[3]);
/* Test 5: Check norm of r'*A */
/* workspace: NRHS*(M+N) */
result[4] = 0.;
if (m > crank) {
result[4] = zqrt17_("No transpose", &c__1, &m, &n,
&nrhs, ©a[1], &lda, &b[1], &ldb, &
copyb[1], &ldb, &c__[1], &work[1], &lwork);
}
/* Test 6: Check if x is in the rowspace of A */
/* workspace: (M+NRHS)*(N+2) */
result[5] = 0.;
if (n > crank) {
result[5] = zqrt14_("No transpose", &m, &n, &nrhs,
©a[1], &lda, &b[1], &ldb, &work[1], &
lwork);
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 3; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 4;
/* Loop for testing different block sizes. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
xlaenv_(&c__3, &nxval[inb]);
/* Test ZGELSY */
/* ZGELSY: Compute the minimum-norm solution */
/* X to min( norm( A * X - B ) ) */
/* using the rank-revealing orthogonal */
/* factorization. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
/* Initialize vector IWORK. */
i__5 = n;
for (j = 1; j <= i__5; ++j) {
iwork[j] = 0;
/* L70: */
}
/* Set LWLSY to the adequate value. */
/* Computing MAX */
i__5 = mnmin << 1, i__6 = nb * (n + 1), i__5 =
max(i__5,i__6), i__6 = mnmin + nb * nrhs;
lwlsy = mnmin + max(i__5,i__6);
lwlsy = max(1,lwlsy);
s_copy(srnamc_1.srnamt, "ZGELSY", (ftnlen)6, (
ftnlen)6);
zgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
iwork[1], &rcond, &crank, &work[1], &
lwlsy, &rwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSY", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) */
/* Test 7: Compute relative error in svd */
/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
result[6] = zqrt12_(&crank, &crank, &a[1], &lda, &
copys[1], &work[1], &lwork, &rwork[1]);
/* Test 8: Compute error in solution */
/* workspace: M*NRHS + M */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[7]);
/* Test 9: Check norm of r'*A */
/* workspace: NRHS*(M+N) */
result[8] = 0.;
if (m > crank) {
result[8] = zqrt17_("No transpose", &c__1, &m,
&n, &nrhs, ©a[1], &lda, &b[1], &
ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 10: Check if x is in the rowspace of A */
/* workspace: (M+NRHS)*(N+2) */
result[9] = 0.;
if (n > crank) {
result[9] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test ZGELSS */
/* ZGELSS: Compute the minimum-norm solution */
/* X to min( norm( A * X - B ) ) */
/* using the SVD. */
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "ZGELSS", (ftnlen)6, (
ftnlen)6);
zgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
rwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSS", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* workspace used: 3*min(m,n) + */
/* max(2*min(m,n),nrhs,max(m,n)) */
/* Test 11: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
, &c__1);
result[10] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[10] = 0.;
}
/* Test 12: Compute error in solution */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[11]);
/* Test 13: Check norm of r'*A */
result[12] = 0.;
if (m > crank) {
result[12] = zqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 14: Check if x is in the rowspace of A */
result[13] = 0.;
if (n > crank) {
result[13] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Test ZGELSD */
/* ZGELSD: Compute the minimum-norm solution X */
/* to min( norm( A * X - B ) ) using a */
/* divide and conquer SVD. */
xlaenv_(&c__9, &c__25);
zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
lda);
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
&ldb);
s_copy(srnamc_1.srnamt, "ZGELSD", (ftnlen)6, (
ftnlen)6);
zgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
s[1], &rcond, &crank, &work[1], &lwork, &
rwork[1], &iwork[1], &info);
if (info != 0) {
alaerh_(path, "ZGELSD", &info, &c__0, " ", &m,
&n, &nrhs, &c_n1, &nb, &itype, &
nfail, &nerrs, nout);
}
/* Test 15: Compute relative error in svd */
if (rank > 0) {
daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
, &c__1);
result[14] = dasum_(&mnmin, &s[1], &c__1) /
dasum_(&mnmin, ©s[1], &c__1) / (
eps * (doublereal) mnmin);
} else {
result[14] = 0.;
}
/* Test 16: Compute error in solution */
zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
1], &ldwork);
zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
&lda, &b[1], &ldb, &work[1], &ldwork, &
rwork[1], &result[15]);
/* Test 17: Check norm of r'*A */
result[16] = 0.;
if (m > crank) {
result[16] = zqrt17_("No transpose", &c__1, &
m, &n, &nrhs, ©a[1], &lda, &b[1],
&ldb, ©b[1], &ldb, &c__[1], &work[
1], &lwork);
}
/* Test 18: Check if x is in the rowspace of A */
result[17] = 0.;
if (n > crank) {
result[17] = zqrt14_("No transpose", &m, &n, &
nrhs, ©a[1], &lda, &b[1], &ldb, &
work[1], &lwork);
}
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 7; k <= 18; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun += 12;
/* L90: */
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVLS */
} /* zdrvls_ */
