/* Subroutine */ int cdrvsy_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *ainv, complex *b, complex *x, complex *
xact, complex *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 facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\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[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio =\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode, imat, info;
static char path[3], dist[1], uplo[1], type__[1];
static integer nrun, i__, j, k, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4], nbmin;
static real rcond;
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, real *, real *, real *);
static real anorm;
extern /* Subroutine */ int csyt01_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, complex *, integer *, real *,
real *), csyt02_(char *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *);
static integer iuplo, izero, i1, i2, k1, lwork, nerrs;
static logical zerot;
extern /* Subroutine */ int csysv_(char *, integer *, integer *, complex *
, integer *, integer *, complex *, integer *, complex *, integer *
, integer *);
static char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, 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 real rcondc;
extern /* Subroutine */ int 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 *), alasvm_(char *, integer *, integer
*, integer *, integer *);
static real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *);
static real ainvnm;
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int xlaenv_(integer *, integer *), clatsy_(char *,
integer *, complex *, integer *, integer *), cerrvx_(
char *, integer *), csytrf_(char *, integer *, complex *,
integer *, integer *, complex *, integer *, integer *),
csytri_(char *, integer *, complex *, integer *, integer *,
complex *, integer *);
static real result[6];
extern /* Subroutine */ int csysvx_(char *, char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, complex *
, integer *, real *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVSY tests the driver routines CSYSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
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*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(2,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
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;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (imat != 11) {
/* Set up parameters with 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)6, (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 L160;
}
/* For types 3-6, zero one or more rows and columns of
the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.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 {
if (iuplo == 1) {
/* Set the first IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* IMAT = NTYPES: Use a special block diagonal matrix to
test alternate code for the 2-by-2 blocks. */
clatsy_(uplo, &n, &a[1], &lda, iseed);
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with
the value returned by CSYSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = clansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
/* Factor the matrix A. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
csytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
&lwork, &info);
/* Compute inv(A) and take its norm. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
csytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
ainvnm = clansy_("1", uplo, &n, &ainv[1], &lda, &
rwork[1]);
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (ftnlen)6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test CSYSV --- */
if (ifact == 2) {
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using CSYSV. */
s_copy(srnamc_1.srnamt, "CSYSV ", (ftnlen)6, (ftnlen)
6);
csysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
1], &lda, &work[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 CSYSV . */
if (info != k) {
alaerh_(path, "CSYSV ", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L120;
} else if (info != 0) {
goto L120;
}
/* Reconstruct matrix from factors and compute
residual. */
csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
1], &ainv[1], &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CSYSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
L120:
;
}
/* --- Test CSYSVX --- */
if (ifact == 2) {
claset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
}
claset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CSYSVX. */
s_copy(srnamc_1.srnamt, "CSYSVX", (ftnlen)6, (ftnlen)6);
csysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
rwork[(*nrhs << 1) + 1], &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from CSYSVX. */
if (info != k) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CSYSVX", &info, &k, ch__1, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L150;
}
if (info == 0) {
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
cpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CSYSVX with the computed value
in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "CSYSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L140: */
}
nrun = nrun + 7 - k1;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVSY */
} /* cdrvsy_ */
/* Subroutine */ int cdrvpo_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
x, complex *xact, real *s, 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 facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Local variables */
integer i__, k, n;
real *errbnds_c__, *errbnds_n__;
integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
real *berr;
char dist[1];
real rpvgrw_svxx__;
char uplo[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4], nfact;
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
real anorm;
logical equil;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
logical prefac;
real rcondc;
logical nofact;
integer iequed;
real cndnum;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 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 */
/* ======= */
/* CDRVPO tests the driver routines CPOSV, -SVX, and -SVXX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* 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) */
/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* 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;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--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) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* 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 L120;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L120;
}
/* 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 L110;
}
/* 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);
/* Save a copy of the matrix A in ASAV. */
clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
for (i__ = 1; i__ <= 6; ++i__) {
result[i__ - 1] = 0.f;
}
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L90;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by CPOSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhe_(uplo, &n, &afac[1], &lda, &s[1], &
scond, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in CGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = clanhe_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
cpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
cpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
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);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test CPOSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
ftnlen)6);
cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from CPOSV . */
if (info != izero) {
alaerh_(path, "CPOSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
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[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "CPOSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test CPOSVX --- */
if (! prefac) {
claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using CPOSVX. */
s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
6);
cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
&rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CPOSVX. */
if (info == n + 1) {
goto L90;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "CPOSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPOSVX with the computed value */
/* in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "CPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
} else {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "CPOSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
/* --- Test CPOSVXX --- */
/* Restore the matrices A and B. */
clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
if (! prefac) {
claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using CPOSVXX. */
s_copy(srnamc_1.srnamt, "CPOSVXX", (ftnlen)32, (
ftnlen)7);
salloc3();
cposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
&lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
&rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
errbnds_n__, errbnds_c__, &c__0, &c_b94, &
work[1], &rwork[(*nrhs << 1) + 1], &info);
free3();
/* Check the error code from CPOSVXX. */
if (info == n + 1) {
goto L90;
}
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "CPOSVXX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPOSVXX with the computed value */
/* in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___58.ciunit = *nout;
s_wsfe(&io___58);
do_fio(&c__1, "CPOSVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
} else {
io___59.ciunit = *nout;
s_wsfe(&io___59);
do_fio(&c__1, "CPOSVXX", (ftnlen)7);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L85: */
}
nrun = nrun + 7 - k1;
L90:
;
}
/* L100: */
}
L110:
;
}
L120:
;
}
/* L130: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
/* Test Error Bounds for CGESVXX */
cebchvxx_(thresh, path);
return 0;
/* End of CDRVPO */
} /* cdrvpo_ */
/* Subroutine */ int cdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, complex *af,
complex *b, complex *x, complex *xact, complex *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
" ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static real cond;
static integer mode, koff, imat, info;
static char path[3], dist[1], type__[1];
static integer nrun, i__, j, k, m, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4];
static real z__[3];
extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
complex *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *), cgtt02_(char *, integer *,
integer *, complex *, complex *, complex *, complex *, integer *,
complex *, integer *, real *, real *);
static real rcond;
extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
static real anorm;
static integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cgtsv_(integer *, integer *, complex *,
complex *, complex *, complex *, integer *, integer *);
static char trans[1];
static integer izero, nerrs, k1;
static logical zerot;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix, nt;
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static real rcondc;
extern doublereal clangt_(char *, integer *, complex *, complex *,
complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), claset_(char *, integer *, integer
*, complex *, complex *, complex *, integer *);
static real rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real rcondo, anormi;
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cgttrf_(integer *, complex *, complex *,
complex *, complex *, integer *, integer *);
static logical trfcon;
static real anormo;
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cgtsvx_(char *, char *, integer *, integer *,
complex *, complex *, complex *, complex *, complex *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, real *, complex *, real *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVGT tests CGTSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX array, dimension (NMAX*4)
AF (workspace) COMPLEX array, dimension (NMAX*4)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number.
Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with
unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
clarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
csscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
i__3 = n;
a[i__3].r = z__[1], a[i__3].i = 0.f;
if (n > 1) {
a[1].r = z__[2], a[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n * 3 - 2;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = z__[1], a[i__3].i = 0.f;
} else {
i__3 = (n << 1) - 2 + izero;
a[i__3].r = z__[0], a[i__3].i = 0.f;
i__3 = n - 1 + izero;
a[i__3].r = z__[1], a[i__3].i = 0.f;
i__3 = izero;
a[i__3].r = z__[2], a[i__3].i = 0.f;
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
i__3 = n;
z__[1] = a[i__3].r;
i__3 = n;
a[i__3].r = 0.f, a[i__3].i = 0.f;
if (n > 1) {
z__[2] = a[1].r;
a[1].r = 0.f, a[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
i__3 = n * 3 - 2;
z__[0] = a[i__3].r;
i__3 = (n << 1) - 1;
z__[1] = a[i__3].r;
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = (n << 1) - 2 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = n - 1 + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
i__4 = i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
i__3 = n * 3 - 2;
a[i__3].r = 0.f, a[i__3].i = 0.f;
i__3 = (n << 1) - 1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with
the value returned by CGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = clangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use CGTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L30: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use CGTTRS to solve for one column at a time of
inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
&iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
clagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test CGTSV ---
Solve the system using Gaussian elimination with
partial pivoting. */
i__3 = n + (m << 1);
ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)6, (ftnlen)
6);
cgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from CGTSV . */
if (info != izero) {
alaerh_(path, "CGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test CGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
af[i__4].r = 0.f, af[i__4].i = 0.f;
/* L90: */
}
}
claset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CGTSVX. */
s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)6, (ftnlen)6);
cgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from CGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
cgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGT */
} /* cdrvgt_ */
/* Subroutine */ int 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 cdrvbd_(integer *nsizes, integer *mm, integer *nn,
integer *ntypes, logical *dotype, integer *iseed, real *thresh,
complex *a, integer *lda, complex *u, integer *ldu, complex *vt,
integer *ldvt, complex *asav, complex *usav, complex *vtsav, real *s,
real *ssav, real *e, complex *work, integer *lwork, real *rwork,
integer *iwork, integer *nounit, integer *info)
{
/* Initialized data */
static char cjob[1*4] = "N" "O" "S" "A";
/* Format strings */
static char fmt_9996[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
",\002)\002)";
static char fmt_9999[] = "(\002 SVD -- Complex Singular Value Decomposit"
"ion Driver \002,/\002 Matrix types (see CDRVBD for details):\002"
",//\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 "
"3 = Evenly spaced singular values near 1\002,/\002 4 = Evenly sp"
"aced singular values near underflow\002,/\002 5 = Evenly spaced "
"singular values near overflow\002,//\002 Tests performed: ( A is"
" dense, U and V are unitary,\002,/19x,\002 S is an array, and Up"
"artial, VTpartial, and\002,/19x,\002 Spartial are partially comp"
"uted U, VT and S),\002,/)";
static char fmt_9998[] = "(\002 Tests performed with Test Threshold ="
" \002,f8.2,/\002 CGESVD: \002,/\002 1 = | A - U diag(S) VT | / ("
" |A| max(M,N) ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp )"
" \002,/\002 3 = | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if"
" S contains min(M,N) nonnegative values in\002,\002 decreasing o"
"rder, else 1/ulp\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/"
"\002 6 = | VT - VTpartial | / ( N ulp )\002,/\002 7 = | S - Spar"
"tial | / ( min(M,N) ulp |S| )\002,/\002 CGESDD: \002,/\002 8 = |"
" A - U diag(S) VT | / ( |A| max(M,N) ulp ) \002,/\002 9 = | I - "
"U**T U | / ( M ulp ) \002,/\00210 = | I - VT VT**T | / ( N ulp ) "
"\002,/\00211 = 0 if S contains min(M,N) nonnegative values in"
"\002,\002 decreasing order, else 1/ulp\002,/\00212 = | U - Upart"
"ial | / ( M ulp )\002,/\00213 = | VT - VTpartial | / ( N ulp "
")\002,/\00214 = | S - Spartial | / ( min(M,N) ulp |S| )\002,//)";
static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
"est(\002,i1,\002)=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9, i__10, i__11, i__12, i__13, i__14;
real r__1, r__2, r__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, m, n;
real dif, div;
integer ijq, iju;
real ulp;
char jobq[1], jobu[1];
integer mmax, nmax;
real unfl, ovfl;
integer ijvt;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *);
logical badmm, badnn;
integer nfail, iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
real anorm;
extern /* Subroutine */ int cunt03_(char *, integer *, integer *, integer
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, real *, real *, integer *);
integer mnmin, mnmax;
char jobvt[1];
integer iwspc, jsize, nerrs, jtype, ntest, iwtmp;
extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex
*, integer *, real *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *,
complex *, integer *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
*, complex *, integer *), claset_(char *, integer *,
integer *, complex *, complex *, complex *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), alasvm_(
char *, integer *, integer *, integer *, integer *),
clatms_(integer *, integer *, char *, integer *, char *, real *,
integer *, real *, real *, integer *, integer *, char *, complex *
, integer *, complex *, integer *);
integer ntestf, minwrk;
real ulpinv, result[14];
integer lswork, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 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 */
/* ======= */
/* CDRVBD checks the singular value decomposition (SVD) driver CGESVD */
/* and CGESDD. */
/* CGESVD and CGESDD factors A = U diag(S) VT, where U and VT are */
/* unitary and diag(S) is diagonal with the entries of the array S on */
/* its diagonal. The entries of S are the singular values, nonnegative */
/* and stored in decreasing order. U and VT can be optionally not */
/* computed, overwritten on A, or computed partially. */
/* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN. */
/* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N. */
/* When CDRVBD is called, a number of matrix "sizes" (M's and N's) */
/* and a number of matrix "types" are specified. For each size (M,N) */
/* and each type of matrix, and for the minimal workspace as well as */
/* workspace adequate to permit blocking, an M x N matrix "A" will be */
/* generated and used to test the SVD routines. For each matrix, A will */
/* be factored as A = U diag(S) VT and the following 12 tests computed: */
/* Test for CGESVD: */
/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
/* (2) | I - U'U | / ( M ulp ) */
/* (3) | I - VT VT' | / ( N ulp ) */
/* (4) S contains MNMIN nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
/* computed U. */
/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
/* computed VT. */
/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
/* vector of singular values from the partial SVD */
/* Test for CGESDD: */
/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
/* (2) | I - U'U | / ( M ulp ) */
/* (3) | I - VT VT' | / ( N ulp ) */
/* (4) S contains MNMIN nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
/* computed U. */
/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
/* computed VT. */
/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
/* vector of singular values from the partial SVD */
/* The "sizes" are specified by the arrays MM(1:NSIZES) and */
/* NN(1:NSIZES); the value of each element pair (MM(j),NN(j)) */
/* specifies one size. The "types" are specified by a logical array */
/* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" */
/* will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A matrix of the form U D V, where U and V are unitary and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (4) Same as (3), but multiplied by the underflow-threshold / ULP. */
/* (5) Same as (3), but multiplied by the overflow-threshold * ULP. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* CDRVBD does nothing. It must be at least zero. */
/* MM (input) INTEGER array, dimension (NSIZES) */
/* An array containing the matrix "heights" to be used. For */
/* each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j) */
/* will be ignored. The MM(j) values must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the matrix "widths" to be used. For */
/* each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j) */
/* will be ignored. The NN(j) values must be at least zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, CDRVBD */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrices are in A and B. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
/* of type j will be generated. If NTYPES is smaller than the */
/* maximum number of types defined (PARAMETER MAXTYP), then */
/* types NTYPES+1 through MAXTYP will not be generated. If */
/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
/* DOTYPE(NTYPES) will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CDRVBD to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (output) COMPLEX array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose singular values are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at */
/* least 1 and at least max( MM ). */
/* U (output) COMPLEX array, dimension (LDU,max(MM)) */
/* Used to hold the computed matrix of right singular vectors. */
/* On exit, U contains the last such vectors actually computed. */
/* LDU (input) INTEGER */
/* The leading dimension of U. It must be at */
/* least 1 and at least max( MM ). */
/* VT (output) COMPLEX array, dimension (LDVT,max(NN)) */
/* Used to hold the computed matrix of left singular vectors. */
/* On exit, VT contains the last such vectors actually computed. */
/* LDVT (input) INTEGER */
/* The leading dimension of VT. It must be at */
/* least 1 and at least max( NN ). */
/* ASAV (output) COMPLEX array, dimension (LDA,max(NN)) */
/* Used to hold a different copy of the matrix whose singular */
/* values are to be computed. On exit, A contains the last */
/* matrix actually used. */
/* USAV (output) COMPLEX array, dimension (LDU,max(MM)) */
/* Used to hold a different copy of the computed matrix of */
/* right singular vectors. On exit, USAV contains the last such */
/* vectors actually computed. */
/* VTSAV (output) COMPLEX array, dimension (LDVT,max(NN)) */
/* Used to hold a different copy of the computed matrix of */
/* left singular vectors. On exit, VTSAV contains the last such */
/* vectors actually computed. */
/* S (output) REAL array, dimension (max(min(MM,NN))) */
/* Contains the computed singular values. */
/* SSAV (output) REAL array, dimension (max(min(MM,NN))) */
/* Contains another copy of the computed singular values. */
/* E (output) REAL array, dimension (max(min(MM,NN))) */
/* Workspace for CGESVD. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all */
/* pairs (M,N)=(MM(j),NN(j)) */
/* RWORK (workspace) REAL array, */
/* dimension ( 5*max(max(MM,NN)) ) */
/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
/* RESULT (output) REAL array, dimension (7) */
/* The values computed by the 7 tests described above. */
/* The values are currently limited to 1/ULP, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some MM(j) < 0 */
/* -3: Some NN(j) < 0 */
/* -4: NTYPES < 0 */
/* -7: THRESH < 0 */
/* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/* -12: LDU < 1 or LDU < MMAX. */
/* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ). */
/* -21: LWORK too small. */
/* If CLATMS, or CGESVD returns an error code, the */
/* absolute value of it is returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--mm;
--nn;
--dotype;
--iseed;
asav_dim1 = *lda;
asav_offset = 1 + asav_dim1;
asav -= asav_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
usav_dim1 = *ldu;
usav_offset = 1 + usav_dim1;
usav -= usav_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vtsav_dim1 = *ldvt;
vtsav_offset = 1 + vtsav_dim1;
vtsav -= vtsav_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--s;
--ssav;
--e;
--work;
--rwork;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
/* Important constants */
nerrs = 0;
ntestt = 0;
ntestf = 0;
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
minwrk = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mm[j];
mmax = max(i__2,i__3);
if (mm[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX */
/* Computing MIN */
i__4 = mm[j], i__5 = nn[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* Computing MAX */
/* Computing MAX */
/* Computing MIN */
i__6 = mm[j], i__7 = nn[j];
/* Computing MAX */
i__9 = mm[j], i__10 = nn[j];
/* Computing 2nd power */
i__8 = max(i__9,i__10);
/* Computing MIN */
i__11 = mm[j], i__12 = nn[j];
/* Computing MAX */
i__13 = mm[j], i__14 = nn[j];
i__4 = min(i__6,i__7) * 3 + i__8 * i__8, i__5 = min(i__11,i__12) * 5,
i__4 = max(i__4,i__5), i__5 = max(i__13,i__14) * 3;
i__2 = minwrk, i__3 = max(i__4,i__5);
minwrk = max(i__2,i__3);
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*ntypes < 0) {
*info = -4;
} else if (*lda < max(1,mmax)) {
*info = -10;
} else if (*ldu < max(1,mmax)) {
*info = -12;
} else if (*ldvt < max(1,nmax)) {
*info = -14;
} else if (minwrk > *lwork) {
*info = -21;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVBD", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = slamch_("S");
ovfl = 1.f / unfl;
ulp = slamch_("E");
ulpinv = 1.f / ulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mm[jsize];
n = nn[jsize];
mnmin = min(m,n);
if (*nsizes != 1) {
mtypes = min(5,*ntypes);
} else {
mtypes = min(6,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
if (mtypes > 5) {
goto L50;
}
if (jtype == 1) {
/* Zero matrix */
claset_("Full", &m, &n, &c_b1, &c_b1, &a[a_offset], lda);
i__3 = min(m,n);
for (i__ = 1; i__ <= i__3; ++i__) {
s[i__] = 0.f;
/* L30: */
}
} else if (jtype == 2) {
/* Identity matrix */
claset_("Full", &m, &n, &c_b1, &c_b2, &a[a_offset], lda);
i__3 = min(m,n);
for (i__ = 1; i__ <= i__3; ++i__) {
s[i__] = 1.f;
/* L40: */
}
} else {
/* (Scaled) random matrix */
if (jtype == 3) {
anorm = 1.f;
}
if (jtype == 4) {
anorm = unfl / ulp;
}
if (jtype == 5) {
anorm = ovfl * ulp;
}
r__1 = (real) mnmin;
i__3 = m - 1;
i__4 = n - 1;
clatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &r__1, &
anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
&iinfo);
if (iinfo != 0) {
io___27.ciunit = *nounit;
s_wsfe(&io___27);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
}
L50:
clacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
/* Do for minimal and adequate (for blocking) workspace */
for (iwspc = 1; iwspc <= 4; ++iwspc) {
/* Test for CGESVD */
iwtmp = (min(m,n) << 1) + max(m,n);
lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
lswork = min(lswork,*lwork);
lswork = max(lswork,1);
if (iwspc == 4) {
lswork = *lwork;
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.f;
/* L60: */
}
/* Factorize A */
if (iwspc > 1) {
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
, lda);
}
cgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
1], &lswork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "GESVD", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Do tests 1--4 */
cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
usav_offset], ldu, &ssav[1], &e[1], &vtsav[
vtsav_offset], ldvt, &work[1], &rwork[1], result);
if (m != 0 && n != 0) {
cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
work[1], lwork, &rwork[1], &result[1]);
cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
work[1], lwork, &rwork[1], &result[2]);
}
result[3] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
result[3] = ulpinv;
}
if (ssav[i__] < 0.f) {
result[3] = ulpinv;
}
/* L70: */
}
if (mnmin >= 1) {
if (ssav[mnmin] < 0.f) {
result[3] = ulpinv;
}
}
/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
result[4] = 0.f;
result[5] = 0.f;
result[6] = 0.f;
for (iju = 0; iju <= 3; ++iju) {
for (ijvt = 0; ijvt <= 3; ++ijvt) {
if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
goto L90;
}
*(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
*(unsigned char *)jobvt = *(unsigned char *)&cjob[
ijvt];
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
a_offset], lda);
cgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
&u[u_offset], ldu, &vt[vt_offset], ldvt, &
work[1], &lswork, &rwork[1], &iinfo);
/* Compare U */
dif = 0.f;
if (m > 0 && n > 0) {
if (iju == 1) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &a[a_offset], lda,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else if (iju == 2) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else if (iju == 3) {
cunt03_("C", &m, &m, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
}
}
result[4] = dmax(result[4],dif);
/* Compare VT */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijvt == 1) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &a[a_offset],
lda, &work[1], lwork, &rwork[1], &dif,
&iinfo);
} else if (ijvt == 2) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
} else if (ijvt == 3) {
cunt03_("R", &n, &n, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
}
}
result[5] = dmax(result[5],dif);
/* Compare S */
dif = 0.f;
/* Computing MAX */
r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_(
"Safe minimum");
div = dmax(r__1,r__2);
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
dif = ulpinv;
}
if (ssav[i__] < 0.f) {
dif = ulpinv;
}
/* Computing MAX */
r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__],
dabs(r__1)) / div;
dif = dmax(r__2,r__3);
/* L80: */
}
result[6] = dmax(result[6],dif);
L90:
;
}
/* L100: */
}
/* Test for CGESDD */
iwtmp = (mnmin << 1) * mnmin + (mnmin << 1) + max(m,n);
lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
lswork = min(lswork,*lwork);
lswork = max(lswork,1);
if (iwspc == 4) {
lswork = *lwork;
}
/* Factorize A */
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
lda);
cgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
1], &lswork, &rwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, "GESDD", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (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 *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Do tests 1--4 */
cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
usav_offset], ldu, &ssav[1], &e[1], &vtsav[
vtsav_offset], ldvt, &work[1], &rwork[1], &result[7]);
if (m != 0 && n != 0) {
cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
work[1], lwork, &rwork[1], &result[8]);
cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
work[1], lwork, &rwork[1], &result[9]);
}
result[10] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
result[10] = ulpinv;
}
if (ssav[i__] < 0.f) {
result[10] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (ssav[mnmin] < 0.f) {
result[10] = ulpinv;
}
}
/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
result[11] = 0.f;
result[12] = 0.f;
result[13] = 0.f;
for (ijq = 0; ijq <= 2; ++ijq) {
*(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
, lda);
cgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
lswork, &rwork[1], &iwork[1], &iinfo);
/* Compare U */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijq == 1) {
if (m >= n) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &a[a_offset], lda,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
}
} else if (ijq == 2) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu, &
work[1], lwork, &rwork[1], &dif, &iinfo);
}
}
result[11] = dmax(result[11],dif);
/* Compare VT */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijq == 1) {
if (m >= n) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
} else {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &a[a_offset],
lda, &work[1], lwork, &rwork[1], &dif,
&iinfo);
}
} else if (ijq == 2) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset], ldvt,
&work[1], lwork, &rwork[1], &dif, &iinfo);
}
}
result[12] = dmax(result[12],dif);
/* Compare S */
dif = 0.f;
/* Computing MAX */
r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_("Safe m"
"inimum");
div = dmax(r__1,r__2);
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
dif = ulpinv;
}
if (ssav[i__] < 0.f) {
dif = ulpinv;
}
/* Computing MAX */
r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], dabs(
r__1)) / div;
dif = dmax(r__2,r__3);
/* L120: */
}
result[13] = dmax(result[13],dif);
/* L130: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= 0.f) {
++ntest;
}
if (result[j - 1] >= *thresh) {
++nfail;
}
/* L140: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= *thresh) {
io___45.ciunit = *nounit;
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 *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwspc, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L150: */
}
nerrs += nfail;
ntestt += ntest;
/* L160: */
}
L170:
;
}
/* L180: */
}
/* Summary */
alasvm_("CBD", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of CDRVBD */
} /* cdrvbd_ */
/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la,
complex *afb, integer *lafb, complex *asav, complex *b, complex *
bsav, complex *x, complex *xact, real *s, complex *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm"
"all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
"crease LA to at least \002,i5)";
static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too "
"small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
"Increase LAFB to at least \002,i5)";
static char fmt_9997[] = "(1x,a6,\002, N=\002,i5,\002, KL=\002,i5,\002, "
"KU=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12."
"5)";
static char fmt_9995[] = "(1x,a6,\002( '\002,a1,\002','\002,a1,\002',"
"\002,i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002"
"', type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a6,\002( '\002,a1,\002','\002,a1,\002',"
"\002,i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, "
"test(\002,i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
double c_abs(complex *);
/* Local variables */
integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
iku, nku;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
char dist[1];
real rdum[1];
char type__[1];
integer nrun, ldafb;
extern /* Subroutine */ int cgbt01_(integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, integer *,
complex *, real *), cgbt02_(char *, integer *, integer *, integer
*, integer *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, real *), cgbt05_(char *, integer
*, integer *, integer *, integer *, complex *, integer *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
integer ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
integer nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc;
extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *,
integer *, complex *, integer *, integer *, complex *, integer *,
integer *);
integer nimat;
real roldi;
extern doublereal sget06_(real *, real *);
real anorm;
integer itran;
logical equil;
real roldo;
char trans[1];
integer izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
extern doublereal clangb_(char *, integer *, integer *, integer *,
complex *, integer *, real *), clange_(char *, integer *,
integer *, complex *, integer *, real *);
extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, char *), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
logical prefac;
real colcnd;
extern doublereal clantb_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, integer *);
real rcondc;
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
integer *, complex *, integer *, integer *, integer *);
integer iequed;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
real rcondi;
extern /* Subroutine */ int 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 *), alasvm_(char *, integer *, integer *, integer *, integer
*);
real cndnum, anormi, rcondo, ainvnm;
extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
*, integer *, complex *, integer *, integer *, complex *, integer
*, integer *), clatms_(integer *, integer *, char *,
integer *, char *, real *, integer *, real *, real *, integer *,
integer *, char *, complex *, integer *, complex *, integer *);
logical trfcon;
real anormo, rowcnd;
extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, char *, real *, real *, complex *, integer *, complex *
, integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *);
real anrmpv;
extern /* Subroutine */ int cerrvx_(char *, integer *);
real result[7], rpvgrw;
/* Fortran I/O blocks */
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___80 = { 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 */
/* ======= */
/* CDRVGB tests the driver routines CGBSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX array, dimension (LA) */
/* LA (input) INTEGER */
/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
/* where NMAX is the largest entry in NVAL. */
/* AFB (workspace) COMPLEX array, dimension (LAFB) */
/* LAFB (input) INTEGER */
/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
/* where NMAX is the largest entry in NVAL. */
/* ASAV (workspace) COMPLEX array, dimension (LA) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (2*NMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS,NMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afb;
--a;
--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, "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) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
ldb = 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);
nkl = max(i__2,i__3);
if (n == 0) {
nkl = 1;
}
nku = nkl;
nimat = 8;
if (n <= 0) {
nimat = 1;
}
i__2 = nkl;
for (ikl = 1; ikl <= i__2; ++ikl) {
/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
/* it easier to skip redundant values for small values of N. */
if (ikl == 1) {
kl = 0;
} else if (ikl == 2) {
/* Computing MAX */
i__3 = n - 1;
kl = max(i__3,0);
} else if (ikl == 3) {
kl = (n * 3 - 1) / 4;
} else if (ikl == 4) {
kl = (n + 1) / 4;
}
i__3 = nku;
for (iku = 1; iku <= i__3; ++iku) {
/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
/* makes it easier to skip redundant values for small */
/* values of N. */
if (iku == 1) {
ku = 0;
} else if (iku == 2) {
/* Computing MAX */
i__4 = n - 1;
ku = max(i__4,0);
} else if (iku == 3) {
ku = (n * 3 - 1) / 4;
} else if (iku == 4) {
ku = (n + 1) / 4;
}
/* Check that A and AFB are big enough to generate this */
/* matrix. */
lda = kl + ku + 1;
ldafb = (kl << 1) + ku + 1;
if (lda * n > *la || ldafb * n > *lafb) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (lda * n > *la) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&(*la), (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__4 = n * (kl + ku + 1);
do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
}
if (ldafb * n > *lafb) {
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&(*lafb), (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__4 = n * ((kl << 1) + ku + 1);
do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
}
goto L130;
}
i__4 = nimat;
for (imat = 1; imat <= i__4; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 2, 3, or 4 if the matrix is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L120;
}
/* Set up parameters with CLATB4 and generate a */
/* test matrix with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &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 L120;
}
/* 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 = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 4) {
/* Computing MAX */
i__5 = 1, i__6 = ku + 2 - izero;
i1 = max(i__5,i__6);
/* Computing MIN */
i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
i2 = min(i__5,i__6);
i__5 = i2;
for (i__ = i1; i__ <= i__5; ++i__) {
i__6 = ioff + i__;
a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L20: */
}
} else {
i__5 = n;
for (j = izero; j <= i__5; ++j) {
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - j;
/* Computing MIN */
i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
i__8 = min(i__9,i__10);
for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
{
i__6 = ioff + i__;
a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L30: */
}
ioff += lda;
/* L40: */
}
}
}
/* Save a copy of the matrix A in ASAV. */
i__5 = kl + ku + 1;
clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__5 = nfact;
for (ifact = 1; ifact <= i__5; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (! nofact) {
/* Compute the condition number for comparison */
/* with the value returned by SGESVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &asav[1], &lda, &
afb[kl + 1], &ldafb);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
ldafb, &s[1], &s[n + 1], &rowcnd,
&colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R")) {
rowcnd = 0.f;
colcnd = 1.f;
} else if (lsame_(equed, "C")) {
rowcnd = 1.f;
colcnd = 0.f;
} else if (lsame_(equed, "B")) {
rowcnd = 0.f;
colcnd = 0.f;
}
/* Equilibrate the matrix. */
claqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
, &ldafb, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in CGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangb_("1", &n, &kl, &ku, &afb[kl +
1], &ldafb, &rwork[1]);
anormi = clangb_("I", &n, &kl, &ku, &afb[kl +
1], &ldafb, &rwork[1]);
/* Factor the matrix A. */
cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
iwork[1], &info);
/* Form the inverse of A. */
claset_("Full", &n, &n, &c_b48, &c_b49, &work[
1], &ldb);
s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)6, (
ftnlen)6);
cgbtrs_("No transpose", &n, &kl, &ku, &n, &
afb[1], &ldafb, &iwork[1], &work[1], &
ldb, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clange_("1", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Compute the infinity-norm condition number */
/* of A. */
ainvnm = clange_("I", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
1], &lda);
/* Form an exact solution and set the right hand */
/* side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (
ftnlen)6);
clarhs_(path, xtype, "Full", trans, &n, &n, &
kl, &ku, nrhs, &a[1], &lda, &xact[1],
&ldb, &b[1], &ldb, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
1], &ldb);
if (nofact && itran == 1) {
/* --- Test CGBSV --- */
/* Compute the LU factorization of the matrix */
/* and solve the system. */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &a[1], &lda, &
afb[kl + 1], &ldafb);
clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
1], &ldb);
s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)
6, (ftnlen)6);
cgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
ldafb, &iwork[1], &x[1], &ldb, &
info);
/* Check error code from CGBSV . */
if (info != izero) {
alaerh_(path, "CGBSV ", &info, &izero,
" ", &n, &n, &kl, &ku, nrhs,
&imat, &nfail, &nerrs, nout);
}
/* Reconstruct matrix from factors and */
/* compute residual. */
cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
afb[1], &ldafb, &iwork[1], &work[
1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed */
/* solution. */
clacpy_("Full", &n, nrhs, &b[1], &ldb,
&work[1], &ldb);
cgbt02_("No transpose", &n, &n, &kl, &
ku, nrhs, &a[1], &lda, &x[1],
&ldb, &work[1], &ldb, &result[
1]);
/* Check solution from generated exact */
/* solution. */
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &rcondc, &result[2])
;
nt = 3;
}
/* Print information about the tests that did */
/* not pass the threshold. */
i__8 = nt;
for (k = 1; k <= i__8; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "CGBSV ", (ftnlen)6)
;
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 *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += nt;
}
/* --- Test CGBSVX --- */
if (! prefac) {
i__8 = (kl << 1) + ku + 1;
claset_("Full", &i__8, &n, &c_b48, &c_b48,
&afb[1], &ldafb);
}
claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
1], &ldb);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
1], &s[n + 1], &rowcnd, &colcnd, &
amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using CGBSVX. */
s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)6, (
ftnlen)6);
cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
, &lda, &afb[1], &ldafb, &iwork[1],
equed, &s[1], &s[ldb + 1], &b[1], &
ldb, &x[1], &ldb, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &rwork[(*
nrhs << 1) + 1], &info);
/* Check the error code from CGBSVX. */
if (info != izero) {
/* Writing concatenation */
i__11[0] = 1, a__1[0] = fact;
i__11[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
2);
alaerh_(path, "CGBSVX", &info, &izero,
ch__1, &n, &n, &kl, &ku, nrhs, &
imat, &nfail, &nerrs, nout);
}
/* Compare RWORK(2*NRHS+1) from CGBSVX with the */
/* computed reciprocal pivot growth RPVGRW */
if (info != 0) {
anrmpv = 0.f;
i__8 = info;
for (j = 1; j <= i__8; ++j) {
/* Computing MAX */
i__6 = ku + 2 - j;
/* Computing MIN */
i__9 = n + ku + 1 - j, i__10 = kl +
ku + 1;
i__7 = min(i__9,i__10);
for (i__ = max(i__6,1); i__ <= i__7;
++i__) {
/* Computing MAX */
r__1 = anrmpv, r__2 = c_abs(&a[
i__ + (j - 1) * lda]);
anrmpv = dmax(r__1,r__2);
/* L60: */
}
/* L70: */
}
/* Computing MIN */
i__7 = info - 1, i__6 = kl + ku;
i__8 = min(i__7,i__6);
/* Computing MAX */
i__9 = 1, i__10 = kl + ku + 2 - info;
rpvgrw = clantb_("M", "U", "N", &info, &
i__8, &afb[max(i__9, i__10)], &
ldafb, rdum);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = anrmpv / rpvgrw;
}
} else {
i__8 = kl + ku;
rpvgrw = clantb_("M", "U", "N", &n, &i__8,
&afb[1], &ldafb, rdum);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = clangb_("M", &n, &kl, &ku, &
a[1], &lda, rdum) /
rpvgrw;
}
}
/* Computing MAX */
r__2 = rwork[(*nrhs << 1) + 1];
result[6] = (r__1 = rpvgrw - rwork[(*nrhs <<
1) + 1], dabs(r__1)) / dmax(r__2,
rpvgrw) / slamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and */
/* compute residual. */
cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
afb[1], &ldafb, &iwork[1], &work[
1], result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &ldb,
&work[1], &ldb);
cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
asav[1], &lda, &x[1], &ldb, &work[
1], &ldb, &result[1]);
/* Check solution from generated exact */
/* solution. */
if (nofact || prefac && lsame_(equed,
"N")) {
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &rcondc, &result[2])
;
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
1], &lda, &bsav[1], &ldb, &x[1], &
ldb, &xact[1], &ldb, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from CGBSVX with the computed */
/* value in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did */
/* not pass the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___73.ciunit = *nout;
s_wsfe(&io___73);
do_fio(&c__1, "CGBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___74.ciunit = *nout;
s_wsfe(&io___74);
do_fio(&c__1, "CGBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&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 *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___75.ciunit = *nout;
s_wsfe(&io___75);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___76.ciunit = *nout;
s_wsfe(&io___76);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&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__1, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___77.ciunit = *nout;
s_wsfe(&io___77);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___78.ciunit = *nout;
s_wsfe(&io___78);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&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__6, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[5],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___79.ciunit = *nout;
s_wsfe(&io___79);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___80.ciunit = *nout;
s_wsfe(&io___80);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&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(real));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* L90: */
}
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGB */
} /* cdrvgb_ */
/* Subroutine */ int sdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
real *e, real *b, real *x, real *xact, real *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVPT tests SPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) REAL array, dimension (NMAX*2) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[i__] = a[ia];
e[i__] = a[ia + 1];
ia += 2;
/* L20: */
}
if (n > 0) {
d__[n] = a[ia];
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
slarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + dabs(e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
1], dabs(r__2));
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
dabs(r__3));
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
sscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1] = z__[2];
}
} else if (izero == n) {
e[n - 1] = z__[0];
d__[n] = z__[1];
} else {
e[izero - 1] = z__[0];
d__[izero] = z__[1];
e[izero] = z__[2];
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1];
e[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
z__[0] = e[n - 1];
e[n - 1] = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
z__[0] = e[izero - 1];
z__[2] = e[izero];
e[izero - 1] = 0.f;
e[izero] = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
&b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slanst_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use SPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test SPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from SPTSV . */
if (info != izero) {
alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
1], &lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test SPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
e[n + i__] = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SPTSVX. */
s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &info);
/* Check the error code from SPTSVX. */
if (info != izero) {
alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPT */
} /* sdrvpt_ */
/* Subroutine */ int cdrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
x, complex *xact, real *s, 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 facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode;
static real amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
static char equed[1];
static real roldc, rcond, scond;
extern /* Subroutine */ int cppt01_(char *, integer *, complex *, complex
*, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static logical equil;
static integer iuplo, izero, nerrs;
extern /* Subroutine */ int cppsv_(char *, integer *, integer *, complex *
, complex *, integer *, integer *);
static integer k1;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
static logical prefac;
static integer ku, nt;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static real rcondc;
extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
real *, real *, char *);
static logical nofact;
static char packit[1];
static integer iequed;
extern /* Subroutine */ int 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 *), alasvm_(char *, integer *, integer
*, integer *, integer *);
static real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *);
static real ainvnm;
extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
real *, real *, integer *), cpptrf_(char *, integer *,
complex *, integer *), cpptri_(char *, integer *, complex
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cppsvx_(char *, char *, integer *, integer *,
complex *, complex *, char *, real *, complex *, integer *,
complex *, integer *, real *, real *, real *, complex *, real *,
integer *);
static integer lda, npp;
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CDRVPP tests the driver routines CPPSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) REAL
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
AFAC (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
ASAV (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
S (workspace) REAL array, dimension (NMAX)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
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) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with CLATB4 and generate a test matrix
with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &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 L120;
}
/* For types 3-5, zero one row and column of the matrix to
test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
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 += i__;
/* 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 = 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.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[1], &c__2, &c__1);
} else {
claipd_(&n, &a[1], &n, &c_n1);
}
/* Save a copy of the matrix A in ASAV. */
ccopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with
the value returned by CPPSVX (FACT = 'N' reuses
the condition number from the previous iteration
with FACT = 'F'). */
ccopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
cppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in CGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = clanhp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
cpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
ccopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
cpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
ccopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (ftnlen)
6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test CPPSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CPPSV ", (ftnlen)6, (
ftnlen)6);
cppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from CPPSV . */
if (info != izero) {
alaerh_(path, "CPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not
pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "CPPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test CPPSVX --- */
if (! prefac && npp > 0) {
claset_("Full", &npp, &c__1, &c_b63, &c_b63, &
afac[1], &npp);
}
claset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y'. */
claqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number
and error bounds using CPPSVX. */
s_copy(srnamc_1.srnamt, "CPPSVX", (ftnlen)6, (ftnlen)
6);
cppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
(*nrhs << 1) + 1], &info);
/* Check the error code from CPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "CPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
cppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
cppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPPSVX with the computed value
in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "CPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "CPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVPP */
} /* cdrvpp_ */
/* Subroutine */ int zdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
doublereal *d__, doublecomplex *e, doublecomplex *b, doublecomplex *x,
doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer
*nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', 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, i__5;
doublereal d__1, d__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static char fact[1];
static doublereal cond;
static integer mode;
static doublereal dmax__;
static integer imat, info;
static char path[3], dist[1], type__[1];
static integer nrun, i__, j, k, n, ifact;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer nfail, iseed[4];
static doublereal z__[3];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer izero, nerrs, k1;
extern /* Subroutine */ int zptt01_(integer *, doublereal *,
doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
doublereal *);
static logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zptt02_(char *, integer *, integer *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *), zptt05_(
integer *, integer *, doublereal *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *), zptsv_(integer *, integer *, doublereal *,
doublecomplex *, doublecomplex *, integer *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *);
static integer ia;
extern /* Subroutine */ int aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, ix, nt;
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal rcondc;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
integer *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
static doublereal ainvnm;
extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlaptm_(char *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublereal result[6];
extern /* Subroutine */ int zpttrf_(integer *, doublereal *,
doublecomplex *, integer *), zerrvx_(char *, integer *),
zpttrs_(char *, integer *, integer *, doublereal *, doublecomplex
*, doublecomplex *, integer *, integer *), zptsvx_(char *,
integer *, integer *, doublereal *, doublecomplex *, doublereal *
, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZDRVPT tests ZPTSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX*16 array, dimension (NMAX*2)
D (workspace) DOUBLE PRECISION array, dimension (NMAX*2)
E (workspace) COMPLEX*16 array, dimension (NMAX*2)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
s_copy(path, "Zomplex 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) {
zerrvx_(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 ZLATB4. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of
known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&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 ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &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 = i__;
i__5 = ia;
d__[i__4] = a[i__5].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 = n;
i__4 = ia;
d__[i__3] = a[i__4].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 D and E have values from [-1,1]. */
dlarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
zlarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = abs(d__[1]);
} else {
d__[1] = abs(d__[1]) + z_abs(&e[1]);
d__[n] = (d__1 = d__[n], abs(d__1)) + z_abs(&e[n - 1])
;
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1)) + z_abs(&
e[i__]) + z_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = idamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
d__1 = anorm / dmax__;
dscal_(&n, &d__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
d__1 = anorm / dmax__;
zdscal_(&i__3, &d__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out
elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1].r = z__[2], e[1].i = 0.;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[n] = z__[1];
} else {
i__3 = izero - 1;
e[i__3].r = z__[0], e[i__3].i = 0.;
d__[izero] = z__[1];
i__3 = izero;
e[i__3].r = z__[2], e[i__3].i = 0.;
}
}
/* For types 8-10, set one row and column of the matrix to
zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.;
if (n > 1) {
z__[2] = e[1].r;
e[1].r = 0., e[1].i = 0.;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0] = e[i__3].r;
i__3 = n - 1;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[n];
d__[n] = 0.;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0] = e[i__3].r;
i__3 = izero - 1;
e[i__3].r = 0., e[i__3].i = 0.;
i__3 = izero;
z__[2] = e[i__3].r;
i__3 = izero;
e[i__3].r = 0., e[i__3].i = 0.;
}
z__[1] = d__[izero];
d__[izero] = 0.;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
zlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
zlaptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
&c_b25, &b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with
the value returned by ZPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = zlanht_("1", &n, &d__[1], &e[1]);
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
zpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use ZPTTRS to solve for one column at a time of
inv(A), computing the maximum column sum as we go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0., x[i__5].i = 0.;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1., x[i__4].i = 0.;
zpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
x[1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test ZPTSV -- */
dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "ZPTSV ", (ftnlen)6, (ftnlen)6);
zptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from ZPTSV . */
if (info != izero) {
alaerh_(path, "ZPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio
norm(L*D*L' - A) / (n * norm(A) * EPS ) */
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
lda, &work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass
the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "ZPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test ZPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.;
i__4 = n + i__;
e[i__4].r = 0., e[i__4].i = 0.;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.;
}
}
zlaset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using ZPTSVX. */
s_copy(srnamc_1.srnamt, "ZPTSVX", (ftnlen)6, (ftnlen)6);
zptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
/* Check the error code from ZPTSVX. */
if (info != izero) {
alaerh_(path, "ZPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio
norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
zptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "ZPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPT */
} /* zdrvpt_ */
/* Subroutine */ int cdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, complex *a, integer *lda, complex *b, complex *s, complex *t,
complex *s2, complex *t2, complex *q, integer *ldq, complex *z__,
complex *alpha1, complex *beta1, complex *alpha2, complex *beta2,
complex *vl, complex *vr, complex *work, integer *lwork, real *rwork,
real *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 CDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see CDRVGG for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
" 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
"I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9,
i__10, i__11;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14, r__15, r__16;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_sign(real *, real *), c_abs(complex *);
void r_cnjg(complex *, complex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double r_imag(complex *);
/* Local variables */
static integer iadd, nmax;
static real temp1, temp2;
static integer j, n;
static logical badnn;
extern /* Subroutine */ int cgegs_(char *, char *, integer *, complex *,
integer *, complex *, integer *, complex *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
integer *), cgegv_(char *, char *, integer *,
complex *, integer *, complex *, integer *, complex *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, integer *), cget51_(integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, complex *, real *, real *), cget52_(logical
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, complex *, complex *, complex *, real *, real *);
static real dumma[4];
static integer iinfo;
static real rmagn[4];
static complex ctemp;
static integer nmats, jsize, nerrs, i1, jtype, ntest, n1;
extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
integer *, logical *, real *, real *, real *, integer *, integer *
, complex *, integer *), cunm2r_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *);
static integer jc, nb;
extern /* Subroutine */ int slabad_(real *, real *);
static integer in, jr;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
static integer ns;
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
static real safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), claset_(char *, integer *, integer *,
complex *, complex *, complex *, integer *), xerbla_(char
*, integer *);
static real ulpinv;
static integer lwkopt, mtypes, ntestt, nbz;
static real ulp;
/* Fortran I/O blocks */
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*s_dim1 + a_1
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVGG checks the nonsymmetric generalized eigenvalue driver
routines.
T T T
CGEGS factors A and B as Q S Z and Q T Z , where means
transpose, T is upper triangular, S is in generalized Schur form
(upper triangular), and Q and Z are unitary. It also
computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) --
thus, w(j) = alpha(j)/beta(j) is a root of the generalized
eigenvalue problem
det( A - w(j) B ) = 0
and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
problem
det( m(j) A - B ) = 0
CGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)), the matrix L whose columns contain the
generalized left eigenvectors l, and the matrix R whose columns
contain the generalized right eigenvectors r for the pair (A,B).
When CDRVGG is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 7
tests will be performed and compared with the threshhold THRESH:
Results from CGEGS:
H
(1) | A - Q S Z | / ( |A| n ulp )
H
(2) | B - Q T Z | / ( |B| n ulp )
H
(3) | I - QQ | / ( n ulp )
H
(4) | I - ZZ | / ( n ulp )
(5) maximum over j of D(j) where:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
Results from CGEGV:
(6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
| l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
where l**H is the conjugate tranpose of l.
(7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
| (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
Test Matrices
---- --------
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random unitary matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
CDRVGG does nothing. It must be at least zero.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, CDRVGG
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to CDRVGG to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. It must be at least zero.
THRSHN (input) REAL
Threshhold for reporting eigenvector normalization error.
If the normalization of any eigenvector differs from 1 by
more than THRSHN*ulp, then a special error message will be
printed. (This is handled separately from the other tests,
since only a compiler or programming error should cause an
error message, at least if THRSHN is at least 5--10.)
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (input/workspace) COMPLEX array, dimension (LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, T, S2, and T2.
It must be at least 1 and at least max( NN ).
B (input/workspace) COMPLEX array, dimension (LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) COMPLEX array, dimension (LDA, max(NN))
The upper triangular matrix computed from A by CGEGS.
T (workspace) COMPLEX array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by CGEGS.
S2 (workspace) COMPLEX array, dimension (LDA, max(NN))
The matrix computed from A by CGEGV. This will be the
Schur (upper triangular) form of some matrix related to A,
but will not, in general, be the same as S.
T2 (workspace) COMPLEX array, dimension (LDA, max(NN))
The matrix computed from B by CGEGV. This will be the
Schur form of some matrix related to B, but will not, in
general, be the same as T.
Q (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (left) unitary matrix computed by CGEGS.
LDQ (input) INTEGER
The leading dimension of Q, Z, VL, and VR. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (right) unitary matrix computed by CGEGS.
ALPHA1 (workspace) COMPLEX array, dimension (max(NN))
BETA1 (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGEGS.
ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of
the matrices in A and B.
ALPHA2 (workspace) COMPLEX array, dimension (max(NN))
BETA2 (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGEGV.
ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of
the matrices in A and B.
VL (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (lower triangular) left eigenvector matrix for the
matrices in A and B.
VR (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (upper triangular) right eigenvector matrix for the
matrices in A and B.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the
sum of the blocksize and number-of-shifts for CHGEQZ, and
NB is the greatest of the blocksizes for CGEQRF, CUNMQR,
and CUNGQR. (The blocksizes and the number-of-shifts are
retrieved through calls to ILAENV.)
RWORK (workspace) REAL array, dimension (8*N)
RESULT (output) REAL array, dimension (7)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1 * 1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1 * 1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--alpha1;
--beta1;
--alpha2;
--beta2;
--work;
--rwork;
--result;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number
of shifts are monotone increasing functions of N.
Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1,
(ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "CUNGQR",
" ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen)
6, (ftnlen)3);
ns = ilaenv_(&c__4, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0, (ftnlen)
6, (ftnlen)3);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = slamch_("Precision");
safmin = slamch_("Safe minimum");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L150;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B
Description of control parameters:
KCLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to CLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
LASIGN: .TRUE. if the diagonal elements of A are to be
multiplied by a random magnitude 1 number.
KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b39, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = q_subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
q[i__5].r = q__1.r, q[i__5].i = q__1.i;
i__5 = z___subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
r__2 = q[i__5].r;
r__1 = r_sign(&c_b39, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1.f, q[i__4].i = 0.f;
i__4 = n + 1 - jc;
clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
r__2 = z__[i__5].r;
r__1 = r_sign(&c_b39, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1.f, z__[i__4].i = 0.f;
/* L50: */
}
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1.f, q[i__3].i = 0.f;
i__3 = n;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n * 3;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1.f, z__[i__3].i = 0.f;
i__3 = n << 1;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n << 2;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = a_subscr(jr, jc);
q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
q__1.i = q__2.r * a[i__7].i + q__2.i * a[
i__7].r;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = b_subscr(jr, jc);
q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
q__1.i = q__2.r * b[i__7].i + q__2.i * b[
i__7].r;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
/* Call CGEGS to compute H, T, Q, Z, alpha, and beta. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
cgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "CGEGS", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L130;
}
ntest = 4;
/* Do tests 1--4 */
cget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[1]);
cget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[2]);
cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], &
result[3]);
cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
&result[4]);
/* Do test 5: compare eigenvalues with diagonals. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = s_subscr(j, j);
q__2.r = alpha1[i__4].r - s[i__5].r, q__2.i = alpha1[i__4].i
- s[i__5].i;
q__1.r = q__2.r, q__1.i = q__2.i;
i__6 = j;
i__7 = t_subscr(j, j);
q__4.r = beta1[i__6].r - t[i__7].r, q__4.i = beta1[i__6].i -
t[i__7].i;
q__3.r = q__4.r, q__3.i = q__4.i;
/* Computing MAX */
i__8 = j;
i__9 = s_subscr(j, j);
r__13 = safmin, r__14 = (r__1 = alpha1[i__8].r, dabs(r__1)) +
(r__2 = r_imag(&alpha1[j]), dabs(r__2)), r__13 = max(
r__13,r__14), r__14 = (r__3 = s[i__9].r, dabs(r__3))
+ (r__4 = r_imag(&s_ref(j, j)), dabs(r__4));
/* Computing MAX */
i__10 = j;
i__11 = t_subscr(j, j);
r__15 = safmin, r__16 = (r__5 = beta1[i__10].r, dabs(r__5)) +
(r__6 = r_imag(&beta1[j]), dabs(r__6)), r__15 = max(
r__15,r__16), r__16 = (r__7 = t[i__11].r, dabs(r__7))
+ (r__8 = r_imag(&t_ref(j, j)), dabs(r__8));
temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&q__1)
, dabs(r__10))) / dmax(r__13,r__14) + ((r__11 =
q__3.r, dabs(r__11)) + (r__12 = r_imag(&q__3), dabs(
r__12))) / dmax(r__15,r__16)) / ulp;
temp1 = dmax(temp1,temp2);
/* L120: */
}
result[5] = temp1;
/* Call CGEGV to compute S2, T2, VL, and VR, do tests.
Eigenvalues and Eigenvectors */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
cgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset],
ldq, &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L130;
}
ntest = 7;
/* Do Tests 6 and 7 */
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L130:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "CGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
} else {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
}
/* L140: */
}
L150:
;
}
/* L160: */
}
/* Summary */
alasvm_("CGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of CDRVGG */
} /* cdrvgg_ */
/* Subroutine */ int ddrvsp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, 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 facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\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[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio =\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, j, k, n, i1, i2, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode, imat, info;
char path[3], dist[1], uplo[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int 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 dppt02_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *), dspt01_(char *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
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, lwork;
extern /* Subroutine */ int dspsv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
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 *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int alasvm_(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 *);
doublereal ainvnm;
extern /* Subroutine */ int dsptrf_(char *, integer *, doublereal *,
integer *, integer *), dsptri_(char *, integer *,
doublereal *, integer *, doublereal *, integer *),
derrvx_(char *, integer *);
doublereal result[6];
extern /* Subroutine */ int dspsvx_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 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 */
/* ======= */
/* DDRVSP tests the driver routines DSPSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(2,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 10;
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 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) {
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'R';
}
/* 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, 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 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) * 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 {
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 += 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__) {
a[ioff + i__] = 0.;
/* L80: */
}
ioff = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with */
/* the value returned by DSPSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
/* Factor the matrix A. */
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Compute inv(A) and take its norm. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
dsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
info);
ainvnm = dlansp_("1", uplo, &n, &ainv[1], &rwork[1]);
/* Compute the 1-norm condition number of A. */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Form an exact solution and set the right hand side. */
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);
*(unsigned char *)xtype = 'C';
/* --- Test DSPSV --- */
if (ifact == 2) {
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using DSPSV. */
s_copy(srnamc_1.srnamt, "DSPSV ", (ftnlen)6, (ftnlen)
6);
dspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
lda, &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 DSPSV . */
if (info != k) {
alaerh_(path, "DSPSV ", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L120;
} else if (info != 0) {
goto L120;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
, &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "DSPSV ", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
L120:
;
}
/* --- Test DSPSVX --- */
if (ifact == 2 && npp > 0) {
dlaset_("Full", &npp, &c__1, &c_b59, &c_b59, &afac[1],
&npp);
}
dlaset_("Full", &n, nrhs, &c_b59, &c_b59, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using DSPSVX. */
s_copy(srnamc_1.srnamt, "DSPSVX", (ftnlen)6, (ftnlen)6);
dspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
&b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from DSPSVX. */
if (info != k) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DSPSVX", &info, &k, ch__1, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L150;
}
if (info == 0) {
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
&lda, &rwork[(*nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
dppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from DSPSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "DSPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L140: */
}
nrun = nrun + 7 - k1;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVSP */
} /* ddrvsp_ */
/* Subroutine */ int ddrgev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
*t, doublereal *q, integer *ldq, doublereal *z__, doublereal *qe,
integer *ldqe, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *alphr1, doublereal *alphi1, doublereal *beta1,
doublereal *work, integer *lwork, doublereal *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 DDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
"oblem driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see DDRGEV for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
integer i__, j, n, n1, jc, in, jr;
doublereal ulp;
integer iadd, ierr, nmax;
logical badnn;
extern /* Subroutine */ int dget52_(logical *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dggev_(char *, char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *);
doublereal rmagn[4];
integer nmats, jsize, nerrs, jtype;
extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *), dorm2r_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal dlarnd_(integer *, integer *);
doublereal safmin;
integer ioldsd[4];
doublereal safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
alasvm_(char *, integer *, integer *, integer *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRGEV checks the nonsymmetric generalized eigenvalue problem driver */
/* routine DGGEV. */
/* DGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the */
/* generalized eigenvalues and, optionally, the left and right */
/* eigenvectors. */
/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
/* usually represented as the pair (alpha,beta), as there is reasonalbe */
/* interpretation for beta=0, and even for both being zero. */
/* A right generalized eigenvector corresponding to a generalized */
/* eigenvalue w for a pair of matrices (A,B) is a vector r such that */
/* (A - wB) * r = 0. A left generalized eigenvector is a vector l such */
/* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. */
/* When DDRGEV is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following tests */
/* will be performed and compared with the threshhold THRESH. */
/* Results from DGGEV: */
/* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of */
/* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) */
/* where VL**H is the conjugate-transpose of VL. */
/* (2) | |VL(i)| - 1 | / ulp and whether largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of */
/* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) */
/* (4) | |VR(i)| - 1 | / ulp and whether largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when both l and r */
/* are also computed, and W(partial) denotes the eigenvalues */
/* computed when only W, only W and r, or only W and l are */
/* computed. */
/* (6) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when both l */
/* and r are computed, and VL(partial) denotes the result */
/* when only l is computed. */
/* (7) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when both l */
/* and r are also computed, and VR(partial) denotes the result */
/* when only l is computed. */
/* Test Matrices */
/* ---- -------- */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IERR not equal to 0.) */
/* A (input/workspace) DOUBLE PRECISION array, */
/* dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) DOUBLE PRECISION array, */
/* dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) DOUBLE PRECISION array, */
/* dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by DGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) DOUBLE PRECISION array, */
/* dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by DGGES. */
/* Q (workspace) DOUBLE PRECISION array, */
/* dimension (LDQ, max(NN)) */
/* The (left) eigenvectors matrix computed by DGGEV. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by DGGES. */
/* QE (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
/* QE holds the computed right or left eigenvectors. */
/* LDQE (input) INTEGER */
/* The leading dimension of QE. LDQE >= max(1,max(NN)). */
/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by DGGEV. */
/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
/* generalized eigenvalue of A and B. */
/* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Like ALPHAR, ALPHAI, BETA, these arrays contain the */
/* eigenvalues of A and B, but those computed when DGGEV only */
/* computes a partial eigendecomposition, i.e. not the */
/* eigenvalues and left and right eigenvectors. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ). */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1;
qe -= qe_offset;
--alphar;
--alphai;
--beta;
--alphr1;
--alphi1;
--beta1;
--work;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = 1, i__2 = nmax << 3, i__1 = max(i__1,i__2), i__2 = nmax * (
nmax + 1);
minwrk = max(i__1,i__2);
maxwrk = nmax * 7 + nmax * ilaenv_(&c__1, "DGEQRF", " ", &nmax, &c__1,
&nmax, &c__0);
/* Computing MAX */
i__1 = maxwrk, i__2 = nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -25;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGEV", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* IASIGN: 1 if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number, =2 if */
/* randomly chosen diagonal blocks are to be rotated */
/* to form 2x2 blocks. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L100;
}
ierr = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b17, &c_b17, &a[a_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a[iadd + iadd * a_dim1] = 1.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b17, &c_b17, &b[b_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b23, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b[iadd + iadd * b_dim1] = 1.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q[jr + jc * q_dim1] = dlarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = dlarnd_(&c__3, &iseed[1]);
/* L30: */
}
i__4 = n + 1 - jc;
dlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = d_sign(&c_b23, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.;
i__4 = n + 1 - jc;
dlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = d_sign(&c_b23, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.;
/* L40: */
}
q[n + n * q_dim1] = 1.;
work[n] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 3] = d_sign(&c_b23, &d__1);
z__[n + n * z_dim1] = 1.;
work[n * 2] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 4] = d_sign(&c_b23, &d__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * a[jr + jc * a_dim1];
b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * b[jr + jc * b_dim1];
/* L50: */
}
/* L60: */
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
dlarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
dlarnd_(&c__2, &iseed[1]);
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.;
/* L110: */
}
/* Call DGGEV to compute eigenvalues and eigenvectors. */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
dggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphar[1], &alphai[1], &beta[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "DGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
/* Do the tests (1) and (2) */
dget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
, &result[1]);
if (result[2] > *thresh) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do the tests (3) and (4) */
dget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
, &result[3]);
if (result[4] > *thresh) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do the test (5) */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
dggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
j] != beta1[j]) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do the test (6): Compute eigenvalues and left eigenvectors, */
/* and test them */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
dggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &qe[qe_offset], ldqe, &
z__[z_offset], ldq, &work[1], lwork, &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "DGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
j] != beta1[j]) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
if (q[j + jc * q_dim1] != qe[j + jc * qe_dim1]) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* DO the test (7): Compute eigenvalues and right eigenvectors, */
/* and test them */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
dggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &qe[
qe_offset], ldqe, &work[1], lwork, &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "DGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
j] != beta1[j]) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
if (z__[j + jc * z_dim1] != qe[j + jc * qe_dim1]) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 7; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "DGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___47.ciunit = *nounit;
s_wsfe(&io___47);
e_wsfe();
io___48.ciunit = *nounit;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("DGV", nounit, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGEV */
} /* ddrgev_ */
/* Subroutine */ int ddrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
*t, doublereal *q, integer *ldq, doublereal *z__, doublereal *alphar,
doublereal *alphai, doublereal *beta, doublereal *work, integer *
lwork, doublereal *result, logical *bwork, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 DDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DDRGES: DGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr"
"iver\002)";
static char fmt_9995[] = "(\002 Matrix types (see DDRGES for details):"
" \002)";
static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in"
" Schur form S\002,/\002 11 = difference between (alpha,beta) and"
" diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct "
"number of \002,\002selected eigenvalues\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, sdim, ierr, nmax, rsub;
static char sort[1];
static doublereal temp1, temp2;
static integer i__, j, n;
static logical badnn;
extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dget53_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dget54_(
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dgges_(char *, char *, char *, L_fp, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, logical *, integer *);
static integer iinfo;
static doublereal rmagn[4];
static integer nmats, jsize, nerrs, i1, jtype, ntest, n1, isort;
extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *), dorm2r_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
static logical ilabad;
static integer jc, nb, in;
extern doublereal dlamch_(char *);
static integer jr;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static doublereal safmin;
static integer ioldsd[4];
static doublereal safmax;
static integer knteig;
extern logical dlctes_(doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static integer minwrk, maxwrk;
static doublereal ulpinv;
static integer mtypes, ntestt;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define s_ref(a_1,a_2) s[(a_2)*s_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- 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
=======
DDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
problem driver DGGES.
DGGES factors A and B as Q S Z' and Q T Z' , where ' means
transpose, T is upper triangular, S is in generalized Schur form
(block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
the 2x2 blocks corresponding to complex conjugate pairs of
generalized eigenvalues), and Q and Z are orthogonal. It also
computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n,
Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic
equation
det( A - w(j) B ) = 0
Optionally it also reorder the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms.
When DDRGES is called, a number of matrix "sizes" ("N's") and a
number of matrix "TYPES" are specified. For each size ("N")
and each TYPE of matrix, a pair of matrices (A, B) will be generated
and used for testing. For each matrix pair, the following 13 tests
will be performed and compared with the threshhold THRESH except
the tests (5), (11) and (13).
(1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
(2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
(3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
(4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
(5) if A is in Schur form (i.e. quasi-triangular form)
(no sorting of eigenvalues)
(6) if eigenvalues = diagonal blocks of the Schur form (S, T),
i.e., test the maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(no sorting of eigenvalues)
(7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp )
(with sorting of eigenvalues).
(8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
(9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
(10) if A is in Schur form (i.e. quasi-triangular form)
(with sorting of eigenvalues).
(11) if eigenvalues = diagonal blocks of the Schur form (S, T),
i.e. test the maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(with sorting of eigenvalues).
(12) if sorting worked and SDIM is the number of eigenvalues
which were SELECTed.
Test Matrices
=============
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
DDRGES does nothing. NSIZES >= 0.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. NN >= 0.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, DDRGES
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A on input.
This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DDRGES to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. THRESH >= 0.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (input/workspace) DOUBLE PRECISION array,
dimension(LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, and T.
It must be at least 1 and at least max( NN ).
B (input/workspace) DOUBLE PRECISION array,
dimension(LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
The Schur form matrix computed from A by DGGES. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by DGGES.
Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
The (left) orthogonal matrix computed by DGGES.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by DGGES.
ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by DGGES.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest
matrix dimension.
RESULT (output) DOUBLE PRECISION array, dimension (15)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
BWORK (workspace) LOGICAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--alphar;
--alphai;
--beta;
--work;
--result;
--bwork;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "DORGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max(
i__1,i__2), i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B
Description of control parameters:
KZLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to DLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
IASIGN: 1 if the diagonal elements of A are to be
multiplied by a random magnitude 1 number, =2 if
randomly chosen diagonal blocks are to be rotated
to form 2x2 blocks.
KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a_ref(iadd, iadd) = 1.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b_ref(iadd, iadd) = 1.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q_ref(jr, jc) = dlarnd_(&c__3, &iseed[1]);
z___ref(jr, jc) = dlarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
dlarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
work[(n << 1) + jc] = d_sign(&c_b32, &q_ref(jc, jc));
q_ref(jc, jc) = 1.;
i__4 = n + 1 - jc;
dlarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
work[n * 3 + jc] = d_sign(&c_b32, &z___ref(jc, jc));
z___ref(jc, jc) = 1.;
/* L50: */
}
q_ref(n, n) = 1.;
work[n] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 3] = d_sign(&c_b32, &d__1);
z___ref(n, n) = 1.;
work[n * 2] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 4] = d_sign(&c_b32, &d__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3
+ jc] * a_ref(jr, jc);
b_ref(jr, jc) = work[(n << 1) + jr] * work[n * 3
+ jc] * b_ref(jr, jc);
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a_ref(jr, jc) = rmagn[kamagn[jtype - 1]] * dlarnd_(&
c__2, &iseed[1]);
b_ref(jr, jc) = rmagn[kbmagn[jtype - 1]] * dlarnd_(&
c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call DGGES to compute H, T, Q, Z, alpha, and beta. */
dlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
dgges_("V", "V", sort, (L_fp)dlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alphar[1], &alphai[1], &
beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "DGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[1]);
dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[2]);
} else {
dget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[7]);
}
dget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[
rsub + 3]);
dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering):
check Schur form of A and compare eigenvalues with
diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = safmin, d__8 = (d__2 = alphar[j], abs(d__2)),
d__7 = max(d__7,d__8), d__8 = (d__3 = s_ref(j,
j), abs(d__3));
/* Computing MAX */
d__9 = safmin, d__10 = (d__5 = beta[j], abs(d__5)),
d__9 = max(d__9,d__10), d__10 = (d__6 = t_ref(
j, j), abs(d__6));
temp2 = ((d__1 = alphar[j] - s_ref(j, j), abs(d__1)) /
max(d__7,d__8) + (d__4 = beta[j] - t_ref(j,
j), abs(d__4)) / max(d__9,d__10)) / ulp;
if (j < n) {
if (s_ref(j + 1, j) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
if (s_ref(j, j - 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s_ref(i1 + 2, i1 + 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
} else if (i1 > 1) {
if (s_ref(i1, i1 - 1) != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (! ilabad) {
dget53_(&s_ref(i1, i1), lda, &t_ref(i1, i1), lda,
&beta[j], &alphar[j], &alphai[j], &temp2,
&ierr);
if (ierr >= 3) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(ierr);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
d__1 = -alphai[i__];
if (dlctes_(&alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__1, &beta[i__])) {
++knteig;
}
if (i__ < n) {
d__1 = -alphai[i__ + 1];
d__2 = -alphai[i__];
if ((dlctes_(&alphar[i__ + 1], &alphai[i__ + 1], &
beta[i__ + 1]) || dlctes_(&alphar[i__ + 1]
, &d__1, &beta[i__ + 1])) && ! (dlctes_(&
alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__2, &beta[i__]))
&& iinfo != n + 2) {
result[12] = ulpinv;
}
}
/* L140: */
}
if (sdim != knteig) {
result[12] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "DGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("DGS", nounit, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGES */
} /* ddrges_ */
/* Subroutine */ int zdrgsx_(integer *nsize, integer *ncmax, doublereal *
thresh, integer *nin, integer *nout, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *ai, doublecomplex *bi, doublecomplex
*z__, doublecomplex *q, doublecomplex *alpha, doublecomplex *beta,
doublecomplex *c__, integer *ldc, doublereal *s, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *iwork, integer *liwork,
logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 ZDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Complex Expert Generalized Sch"
"ur form\002,\002 problem driver\002)";
static char fmt_9994[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,d10.4)";
static char fmt_9998[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9995[] = "(\002Input Example\002)";
static char fmt_9990[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double d_imag(doublecomplex *);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublereal temp1, temp2;
static integer i__, j;
static doublereal abnrm;
static integer ifunc, linfo;
static char sense[1];
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *);
static integer nerrs, ntest;
static doublereal pltru;
extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static logical ilabad;
static doublereal thrsh2;
extern /* Subroutine */ int zlatm5_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
static integer mm, bdspac;
static doublereal pl[2];
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static doublereal weight, diftru;
extern /* Subroutine */ int zgesvd_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer minwrk, maxwrk;
extern /* Subroutine */ int zggesx_(char *, char *, char *, L_fp, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *, integer *,
logical *, integer *);
static doublereal smlnum;
static integer mn2, nptknt;
static doublereal ulpinv, result[10];
static integer ntestt, prtype;
extern logical zlctsx_();
static integer qba, qbb;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___39 = { 0, 0, 1, 0, 0 };
static cilist io___40 = { 0, 0, 1, 0, 0 };
static cilist io___41 = { 0, 0, 0, 0, 0 };
static cilist io___42 = { 0, 0, 0, 0, 0 };
static cilist io___43 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
#define ai_subscr(a_1,a_2) (a_2)*ai_dim1 + a_1
#define ai_ref(a_1,a_2) ai[ai_subscr(a_1,a_2)]
#define bi_subscr(a_1,a_2) (a_2)*bi_dim1 + a_1
#define bi_ref(a_1,a_2) bi[bi_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
ZDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
problem expert driver ZGGESX.
ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate
transpose, S and T are upper triangular (i.e., in generalized Schur
form), and Q and Z are unitary. It also computes the generalized
eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus,
w(j) = alpha(j)/beta(j) is a root of the characteristic equation
det( A - w(j) B ) = 0
Optionally it also reorders the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms; computes a reciprocal condition number for the average
of the selected eigenvalues; and computes a reciprocal condition
number for the right and left deflating subspaces corresponding to
the selected eigenvalues.
When ZDRGSX is called with NSIZE > 0, five (5) types of built-in
matrix pairs are used to test the routine ZGGESX.
When ZDRGSX is called with NSIZE = 0, it reads in test matrix data
to test ZGGESX.
(need more details on what kind of read-in data are needed).
For each matrix pair, the following tests will be performed and
compared with the threshhold THRESH except for the tests (7) and (9):
(1) | A - Q S Z' | / ( |A| n ulp )
(2) | B - Q T Z' | / ( |B| n ulp )
(3) | I - QQ' | / ( n ulp )
(4) | I - ZZ' | / ( n ulp )
(5) if A is in Schur form (i.e. triangular form)
(6) maximum over j of D(j) where:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
(7) if sorting worked and SDIM is the number of eigenvalues
which were selected.
(8) the estimated value DIF does not differ from the true values of
Difu and Difl more than a factor 10*THRESH. If the estimate DIF
equals zero the corresponding true values of Difu and Difl
should be less than EPS*norm(A, B). If the true value of Difu
and Difl equal zero, the estimate DIF should be less than
EPS*norm(A, B).
(9) If INFO = N+3 is returned by ZGGESX, the reordering "failed"
and we check that DIF = PL = PR = 0 and that the true value of
Difu and Difl is < EPS*norm(A, B). We count the events when
INFO=N+3.
For read-in test matrices, the same tests are run except that the
exact value for DIF (and PL) is input data. Additionally, there is
one more test run for read-in test matrices:
(10) the estimated value PL does not differ from the true value of
PLTRU more than a factor THRESH. If the estimate PL equals
zero the corresponding true value of PLTRU should be less than
EPS*norm(A, B). If the true value of PLTRU equal zero, the
estimate PL should be less than EPS*norm(A, B).
Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
matrix pairs are generated and tested. NSIZE should be kept small.
SVD (routine ZGESVD) is used for computing the true value of DIF_u
and DIF_l when testing the built-in test problems.
Built-in Test Matrices
======================
All built-in test matrices are the 2 by 2 block of triangular
matrices
A = [ A11 A12 ] and B = [ B11 B12 ]
[ A22 ] [ B22 ]
where for different type of A11 and A22 are given as the following.
A12 and B12 are chosen so that the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
have prescribed solution R and L.
Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
B11 = I_m, B22 = I_k
where J_k(a,b) is the k-by-k Jordan block with ``a'' on
diagonal and ``b'' on superdiagonal.
Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
second diagonal block in A_11 and each third diagonal block
in A_22 are made as 2 by 2 blocks.
Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
for i=1,...,m, j=1,...,m and
A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
for i=m+1,...,k, j=m+1,...,k
Type 5: (A,B) and have potentially close or common eigenvalues and
very large departure from block diagonality A_11 is chosen
as the m x m leading submatrix of A_1:
| 1 b |
| -b 1 |
| 1+d b |
| -b 1+d |
A_1 = | d 1 |
| -1 d |
| -d 1 |
| -1 -d |
| 1 |
and A_22 is chosen as the k x k leading submatrix of A_2:
| -1 b |
| -b -1 |
| 1-d b |
| -b 1-d |
A_2 = | d 1+b |
| -1-b d |
| -d 1+b |
| -1+b -d |
| 1-d |
and matrix B are chosen as identity matrices (see DLATM5).
Arguments
=========
NSIZE (input) INTEGER
The maximum size of the matrices to use. NSIZE >= 0.
If NSIZE = 0, no built-in tests matrices are used, but
read-in test matrices are used to test DGGESX.
NCMAX (input) INTEGER
Maximum allowable NMAX for generating Kroneker matrix
in call to ZLAKF2
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. THRESH >= 0.
NIN (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, B, AI, BI, Z and Q,
LDA >= max( 1, NSIZE ). For the read-in test,
LDA >= max( 1, N ), N is the size of the test matrices.
B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, B contains the last matrix actually used.
AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Copy of A, modified by ZGGESX.
BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Copy of B, modified by ZGGESX.
Z (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Z holds the left Schur vectors computed by ZGGESX.
Q (workspace) COMPLEX*16 array, dimension (LDA, NSIZE)
Q holds the right Schur vectors computed by ZGGESX.
ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE)
BETA (workspace) COMPLEX*16 array, dimension (NSIZE)
On exit, ALPHA/BETA are the eigenvalues.
C (workspace) COMPLEX*16 array, dimension (LDC, LDC)
Store the matrix generated by subroutine ZLAKF2, this is the
matrix formed by Kronecker products used for estimating
DIF.
LDC (input) INTEGER
The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
S (workspace) DOUBLE PRECISION array, dimension (LDC)
Singular values of C
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 3*NSIZE*NSIZE/2
RWORK (workspace) DOUBLE PRECISION array,
dimension (5*NSIZE*NSIZE/2 - 4)
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= NSIZE + 2.
BWORK (workspace) LOGICAL array, dimension (NSIZE)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code.
=====================================================================
Check for errors
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1 * 1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1 * 1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--alpha;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--s;
--work;
--rwork;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -15;
} else if (*liwork < *nsize + 2) {
*info = -21;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = *nsize * 3 * *nsize / 2;
/* workspace for cggesx */
maxwrk = *nsize * (ilaenv_(&c__1, "ZGEQRF", " ", nsize, &c__1, nsize,
&c__0, (ftnlen)6, (ftnlen)1) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *nsize * (ilaenv_(&c__1, "ZUNGQR", " ", nsize, &
c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)1) + 1);
maxwrk = max(i__1,i__2);
/* workspace for zgesvd */
bdspac = *nsize * 3 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * *nsize * (ilaenv_(&c__1, "ZGEBRD",
" ", &i__3, &i__4, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1) + 1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = dlamch_("P");
ulpinv = 1. / ulp;
smlnum = dlamch_("S") / ulp;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs.
Loop over different functions (IFUNC) of ZGGESX, types (PRTYPE)
of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1. / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
&ai[ai_offset], lda);
zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
&bi[bi_offset], lda);
zlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1,
mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m +
1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
weight, &qba, &qbb);
/* Compute the Schur factorization and swapping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
Swapping is accomplished via the function ZLCTSX
which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
zggesx_("V", "V", "S", (L_fp)zlctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alpha[1], &beta[1], &q[q_offset], lda, &z__[
z_offset], lda, pl, difest, &work[1], lwork, &
rwork[1], &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "ZGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = zlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &rwork[1]);
/* Do tests (1) to (4) */
result[1] = 0.;
zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &rwork[1], result);
zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &rwork[1], &result[1]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &rwork[1], &result[2]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &rwork[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and
compare eigenvalues with diagonals. */
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = ai_subscr(j, j);
z__2.r = alpha[i__4].r - ai[i__5].r, z__2.i = alpha[
i__4].i - ai[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = bi_subscr(j, j);
z__4.r = beta[i__6].r - bi[i__7].r, z__4.i = beta[
i__6].i - bi[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = ai_subscr(j, j);
d__13 = smlnum, d__14 = (d__1 = alpha[i__8].r, abs(
d__1)) + (d__2 = d_imag(&alpha[j]), abs(d__2))
, d__13 = max(d__13,d__14), d__14 = (d__3 =
ai[i__9].r, abs(d__3)) + (d__4 = d_imag(&
ai_ref(j, j)), abs(d__4));
/* Computing MAX */
i__10 = j;
i__11 = bi_subscr(j, j);
d__15 = smlnum, d__16 = (d__5 = beta[i__10].r, abs(
d__5)) + (d__6 = d_imag(&beta[j]), abs(d__6)),
d__15 = max(d__15,d__16), d__16 = (d__7 = bi[
i__11].r, abs(d__7)) + (d__8 = d_imag(&bi_ref(
j, j)), abs(d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 =
d_imag(&z__1), abs(d__10))) / max(d__13,d__14)
+ ((d__11 = z__3.r, abs(d__11)) + (d__12 =
d_imag(&z__3), abs(d__12))) / max(d__15,d__16)
) / ulp;
if (j < mn_1.mplusn) {
i__4 = ai_subscr(j + 1, j);
if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
i__4 = ai_subscr(j, j - 1);
if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its
value. first, compute the exact DIF. */
result[7] = 0.;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two cases, there are
almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
zlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm +
1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1,
mm + 1), &c__[c_offset], ldc);
i__3 = *lwork - 2;
zgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, &rwork[1], info);
diftru = s[mn2];
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] /
diftru;
result[7] = max(d__1,d__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "CGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
/* Tests performed */
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
nptknt = 0;
L80:
io___39.ciunit = *nin;
i__1 = s_rsle(&io___39);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___40.ciunit = *nin;
i__1 = s_rsle(&io___40);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___41.ciunit = *nin;
s_rsle(&io___41);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___42.ciunit = *nin;
s_rsle(&io___42);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L100: */
}
io___43.ciunit = *nin;
s_rsle(&io___43);
do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alpha[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1], lwork, &rwork[1],
&iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "ZGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B)
(should this be norm of (A,B) or (AI,BI)?) */
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = zlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &
rwork[1]);
/* Do tests (1) to (4) */
zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], result);
zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
1]);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &rwork[1], &result[2]
);
zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
3]);
/* Do tests (5) and (6): check Schur form of A and compare
eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
i__2 = j;
i__3 = ai_subscr(j, j);
z__2.r = alpha[i__2].r - ai[i__3].r, z__2.i = alpha[i__2].i - ai[i__3]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = j;
i__5 = bi_subscr(j, j);
z__4.r = beta[i__4].r - bi[i__5].r, z__4.i = beta[i__4].i - bi[i__5]
.i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__6 = j;
i__7 = ai_subscr(j, j);
d__13 = smlnum, d__14 = (d__1 = alpha[i__6].r, abs(d__1)) + (d__2 =
d_imag(&alpha[j]), abs(d__2)), d__13 = max(d__13,d__14),
d__14 = (d__3 = ai[i__7].r, abs(d__3)) + (d__4 = d_imag(&
ai_ref(j, j)), abs(d__4));
/* Computing MAX */
i__8 = j;
i__9 = bi_subscr(j, j);
d__15 = smlnum, d__16 = (d__5 = beta[i__8].r, abs(d__5)) + (d__6 =
d_imag(&beta[j]), abs(d__6)), d__15 = max(d__15,d__16), d__16
= (d__7 = bi[i__9].r, abs(d__7)) + (d__8 = d_imag(&bi_ref(j,
j)), abs(d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&z__1), abs(
d__10))) / max(d__13,d__14) + ((d__11 = z__3.r, abs(d__11)) +
(d__12 = d_imag(&z__3), abs(d__12))) / max(d__15,d__16)) /
ulp;
if (j < mn_1.mplusn) {
i__2 = ai_subscr(j + 1, j);
if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
i__2 = ai_subscr(j, j - 1);
if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.;
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
result[7] = max(d__1,d__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.;
if (pl[0] == 0.) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "CGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___48.ciunit = *nout;
s_wsfe(&io___48);
e_wsfe();
/* Tests performed */
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("CGX", nout, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGSX */
} /* zdrgsx_ */
/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
doublecomplex *alpha, doublecomplex *beta, doublecomplex *work,
integer *lwork, doublereal *rwork, doublereal *result, logical *bwork,
integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
"Schur form S\002,/\002 11 = difference between (alpha,beta) and "
"diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
"umber of \002,\002selected eigenvalues\002,/)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14, d__15, d__16;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j, n, n1, jc, nb, in, jr;
doublereal ulp;
integer iadd, sdim, nmax, rsub;
char sort[1];
doublereal temp1, temp2;
logical badnn;
integer iinfo;
doublereal rmagn[4];
doublecomplex ctemp;
extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *,
doublereal *), zgges_(char *, char *, char *, L_fp, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, logical *, integer *);
integer nmats, jsize;
extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *);
integer nerrs, jtype, ntest, isort;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
integer *, integer *, integer *, integer *, logical *, doublereal
*, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *);
logical ilabad;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal safmin, safmax;
integer knteig, ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern logical zlctes_(doublecomplex *, doublecomplex *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem driver ZGGES. */
/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
/* transpose, S and T are upper triangular (i.e., in generalized Schur */
/* form), and Q and Z are unitary. It also computes the generalized */
/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorder the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms. */
/* When ZDRGES is called, a number of matrix "sizes" ("N's") and a */
/* number of matrix "TYPES" are specified. For each size ("N") */
/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following 13 tests */
/* will be performed and compared with the threshhold THRESH except */
/* the tests (5), (11) and (13). */
/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
/* eigenvalues) */
/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e., test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (no sorting of eigenvalues) */
/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
/* (with sorting of eigenvalues). */
/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) if A is in Schur form (i.e. quasi-triangular form) */
/* (with sorting of eigenvalues). */
/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
/* i.e. test the maximum over j of D(j) where: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* (with sorting of eigenvalues). */
/* (12) if sorting worked and SDIM is the number of eigenvalues */
/* which were CELECTed. */
/* Test Matrices */
/* ============= */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A on input. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. THRESH >= 0. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by ZGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by ZGGES. */
/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by ZGGES. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by ZGGES. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by ZGGES. */
/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
/* and B. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 3*N*N. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
/* Real workspace. */
/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alpha;
--beta;
--work;
--rwork;
--result;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * 3 * nmax;
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = dlamch_("Precision");
safmin = dlamch_("Safe minimum");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* LASIGN: .TRUE. if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number. */
/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = iadd + iadd * a_dim1;
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = iadd + iadd * b_dim1;
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = jr + jc * q_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
q[i__5].r = z__1.r, q[i__5].i = z__1.i;
i__5 = jr + jc * z_dim1;
zlarnd_(&z__1, &c__3, &iseed[1]);
z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
}
i__4 = n + 1 - jc;
zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = jc + jc * q_dim1;
d__2 = q[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * q_dim1;
q[i__4].r = 1., q[i__4].i = 0.;
i__4 = n + 1 - jc;
zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = jc + jc * z_dim1;
d__2 = z__[i__5].r;
d__1 = d_sign(&c_b29, &d__2);
work[i__4].r = d__1, work[i__4].i = 0.;
i__4 = jc + jc * z_dim1;
z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
}
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * q_dim1;
q[i__3].r = 1., q[i__3].i = 0.;
i__3 = n;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n * 3;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__3 = n + n * z_dim1;
z__[i__3].r = 1., z__[i__3].i = 0.;
i__3 = n << 1;
work[i__3].r = 0., work[i__3].i = 0.;
i__3 = n << 2;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * a_dim1;
z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
z__1.i = z__2.r * a[i__7].i + z__2.i * a[
i__7].r;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = (n << 1) + jr;
d_cnjg(&z__3, &work[n * 3 + jc]);
z__2.r = work[i__6].r * z__3.r - work[i__6].i *
z__3.i, z__2.i = work[i__6].r * z__3.i +
work[i__6].i * z__3.r;
i__7 = jr + jc * b_dim1;
z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
z__1.i = z__2.r * b[i__7].i + z__2.i * b[
i__7].r;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = jr + jc * a_dim1;
i__6 = kamagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
a[i__5].r = z__1.r, a[i__5].i = z__1.i;
i__5 = jr + jc * b_dim1;
i__6 = kbmagn[jtype - 1];
zlarnd_(&z__2, &c__4, &iseed[1]);
z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
z__2.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call ZGGES to compute H, T, Q, Z, alpha, and beta. */
zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
&rwork[1], &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[1]);
zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
rwork[1], &result[2]);
} else {
zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ 2]);
}
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
, &result[rsub + 3]);
zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
1], &result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/* check Schur form of A and compare eigenvalues with */
/* diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
i__4 = j;
i__5 = j + j * s_dim1;
z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
.i - s[i__5].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__6 = j;
i__7 = j + j * t_dim1;
z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i
- t[i__7].i;
z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
i__8 = j;
i__9 = j + j * s_dim1;
d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1))
+ (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 =
max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
d__4));
/* Computing MAX */
i__10 = j;
i__11 = j + j * t_dim1;
d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5))
+ (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 =
max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
d__8));
temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3),
abs(d__12))) / max(d__15,d__16)) / ulp;
if (j < n) {
i__4 = j + 1 + j * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
i__4 = j + (j - 1) * s_dim1;
if (s[i__4].r != 0. || s[i__4].i != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
if (zlctes_(&alpha[i__], &beta[i__])) {
++knteig;
}
/* L140: */
}
if (sdim != knteig) {
result[13] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, "ZGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Unitary", (ftnlen)7);
e_wsfe();
/* Tests performed */
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGES */
} /* zdrges_ */
/* Subroutine */ int ddrgsx_(integer *nsize, integer *ncmax, doublereal *
thresh, integer *nin, integer *nout, doublereal *a, integer *lda,
doublereal *b, doublereal *ai, doublereal *bi, doublereal *z__,
doublereal *q, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *c__, integer *ldc, doublereal *s, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, logical *bwork,
integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 DDRGSX: DGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002)\002)";
static char fmt_9996[] = "(\002 DDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
"form\002,\002 problem driver\002)";
static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,d10.4)";
static char fmt_9998[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9994[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, i1, mm;
doublereal pl[2];
integer mn2, qba, qbb;
doublereal ulp, temp1, temp2;
extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dget53_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal abnrm;
integer ifunc, iinfo, linfo;
char sense[1];
integer nerrs, ntest;
extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *);
doublereal pltru;
extern /* Subroutine */ int dlatm5_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *), dlabad_(
doublereal *, doublereal *);
doublereal thrsh2;
logical ilabad;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
integer bdspac;
extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *);
doublereal difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal bignum;
extern /* Subroutine */ int dggesx_(char *, char *, char *, L_fp, char *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, logical *, integer
*), alasvm_(char *, integer *,
integer *, integer *, integer *), xerbla_(char *, integer
*);
doublereal weight, diftru;
extern logical dlctsx_();
integer minwrk, maxwrk;
doublereal smlnum, ulpinv;
integer nptknt;
doublereal result[10];
integer ntestt, prtype;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___42 = { 0, 0, 1, 0, 0 };
static cilist io___43 = { 0, 0, 1, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem expert driver DGGESX. */
/* DGGESX factors A and B as Q S Z' and Q T Z', where ' means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the */
/* characteristic equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorders the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms; computes a reciprocal condition number for the average */
/* of the selected eigenvalues; and computes a reciprocal condition */
/* number for the right and left deflating subspaces corresponding to */
/* the selected eigenvalues. */
/* When DDRGSX is called with NSIZE > 0, five (5) types of built-in */
/* matrix pairs are used to test the routine DGGESX. */
/* When DDRGSX is called with NSIZE = 0, it reads in test matrix data */
/* to test DGGESX. */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH except for the tests (7) and (9): */
/* (1) | A - Q S Z' | / ( |A| n ulp ) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) */
/* (3) | I - QQ' | / ( n ulp ) */
/* (4) | I - ZZ' | / ( n ulp ) */
/* (5) if A is in Schur form (i.e. quasi-triangular form) */
/* (6) maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th and j+1-th eigenvalues. */
/* (7) if sorting worked and SDIM is the number of eigenvalues */
/* which were selected. */
/* (8) the estimated value DIF does not differ from the true values of */
/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
/* equals zero the corresponding true values of Difu and Difl */
/* should be less than EPS*norm(A, B). If the true value of Difu */
/* and Difl equal zero, the estimate DIF should be less than */
/* EPS*norm(A, B). */
/* (9) If INFO = N+3 is returned by DGGESX, the reordering "failed" */
/* and we check that DIF = PL = PR = 0 and that the true value of */
/* Difu and Difl is < EPS*norm(A, B). We count the events when */
/* INFO=N+3. */
/* For read-in test matrices, the above tests are run except that the */
/* exact value for DIF (and PL) is input data. Additionally, there is */
/* one more test run for read-in test matrices: */
/* (10) the estimated value PL does not differ from the true value of */
/* PLTRU more than a factor THRESH. If the estimate PL equals */
/* zero the corresponding true value of PLTRU should be less than */
/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
/* estimate PL should be less than EPS*norm(A, B). */
/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
/* matrix pairs are generated and tested. NSIZE should be kept small. */
/* SVD (routine DGESVD) is used for computing the true value of DIF_u */
/* and DIF_l when testing the built-in test problems. */
/* Built-in Test Matrices */
/* ====================== */
/* All built-in test matrices are the 2 by 2 block of triangular */
/* matrices */
/* A = [ A11 A12 ] and B = [ B11 B12 ] */
/* [ A22 ] [ B22 ] */
/* where for different type of A11 and A22 are given as the following. */
/* A12 and B12 are chosen so that the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* have prescribed solution R and L. */
/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
/* B11 = I_m, B22 = I_k */
/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
/* diagonal and ``b'' on superdiagonal. */
/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
/* second diagonal block in A_11 and each third diagonal block */
/* in A_22 are made as 2 by 2 blocks. */
/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
/* for i=1,...,m, j=1,...,m and */
/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
/* for i=m+1,...,k, j=m+1,...,k */
/* Type 5: (A,B) and have potentially close or common eigenvalues and */
/* very large departure from block diagonality A_11 is chosen */
/* as the m x m leading submatrix of A_1: */
/* | 1 b | */
/* | -b 1 | */
/* | 1+d b | */
/* | -b 1+d | */
/* A_1 = | d 1 | */
/* | -1 d | */
/* | -d 1 | */
/* | -1 -d | */
/* | 1 | */
/* and A_22 is chosen as the k x k leading submatrix of A_2: */
/* | -1 b | */
/* | -b -1 | */
/* | 1-d b | */
/* | -b 1-d | */
/* A_2 = | d 1+b | */
/* | -1-b d | */
/* | -d 1+b | */
/* | -1+b -d | */
/* | 1-d | */
/* and matrix B are chosen as identity matrices (see DLATM5). */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The maximum size of the matrices to use. NSIZE >= 0. */
/* If NSIZE = 0, no built-in tests matrices are used, but */
/* read-in test matrices are used to test DGGESX. */
/* NCMAX (input) INTEGER */
/* Maximum allowable NMAX for generating Kroneker matrix */
/* in call to DLAKF2 */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. THRESH >= 0. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Used to store the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Z and Q, */
/* LDA >= max( 1, NSIZE ). For the read-in test, */
/* LDA >= max( 1, N ), N is the size of the test matrices. */
/* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Used to store the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Copy of A, modified by DGGESX. */
/* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Copy of B, modified by DGGESX. */
/* Z (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Z holds the left Schur vectors computed by DGGESX. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
/* Q holds the right Schur vectors computed by DGGESX. */
/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
/* C (workspace) DOUBLE PRECISION array, dimension (LDC, LDC) */
/* Store the matrix generated by subroutine DLAKF2, this is the */
/* matrix formed by Kronecker products used for estimating */
/* DIF. */
/* LDC (input) INTEGER */
/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
/* S (workspace) DOUBLE PRECISION array, dimension (LDC) */
/* Singular values of C */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) ) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= NSIZE + 6. */
/* BWORK (workspace) LOGICAL array, dimension (LDA) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--s;
--work;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -17;
} else if (*liwork < *nsize + 6) {
*info = -21;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
minwrk = max(i__1,i__2);
/* workspace for sggesx */
maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "DGEQRF", " ",
nsize, &c__1, nsize, &c__0);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"DORGQR", " ", nsize, &c__1, nsize, &c_n1);
maxwrk = max(i__1,i__2);
/* workspace for dgesvd */
bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
ilaenv_(&c__1, "DGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = dlamch_("P");
ulpinv = 1. / ulp;
smlnum = dlamch_("S") / ulp;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs. */
/* Loop over different functions (IFUNC) of DGGESX, types (PRTYPE) */
/* of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1. / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &ai[ai_offset], lda);
dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &bi[bi_offset], lda);
dlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
(mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
q_offset], lda, &z__[z_offset], lda, &weight, &
qba, &qbb);
/* Compute the Schur factorization and swapping the */
/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
/* Swapping is accomplished via the function DLCTSX */
/* which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
dggesx_("V", "V", "S", (L_fp)dlctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alphar[1], &alphai[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "DGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = dlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &work[1]);
/* Do tests (1) to (4) */
dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], result);
dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &result[1]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &result[2]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and */
/* compare eigenvalues with diagonals. */
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)
), d__7 = max(d__7,d__8), d__8 = (d__3 =
ai[j + j * ai_dim1], abs(d__3));
/* Computing MAX */
d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5))
, d__9 = max(d__9,d__10), d__10 = (d__6 =
bi[j + j * bi_dim1], abs(d__6));
temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1],
abs(d__1)) / max(d__7,d__8) + (d__4 =
beta[j] - bi[j + j * bi_dim1], abs(d__4))
/ max(d__9,d__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 +
i1 * bi_dim1], lda, &beta[j], &alphar[
j], &alphai[j], &temp2, &iinfo);
if (iinfo >= 3) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its */
/* value. first, compute the exact DIF. */
result[7] = 0.;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two causes, there are */
/* almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
dlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
(mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
i__3 = *lwork - 2;
dgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, info);
diftru = s[mn2];
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] /
diftru;
result[7] = max(d__1,d__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
/* Tests performed */
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
nptknt = 0;
L80:
io___42.ciunit = *nin;
i__1 = s_rsle(&io___42);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___43.ciunit = *nin;
i__1 = s_rsle(&io___43);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nin;
s_rsle(&io___44);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___45.ciunit = *nin;
s_rsle(&io___45);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L100: */
}
io___46.ciunit = *nin;
s_rsle(&io___46);
do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the */
/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "DGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B) */
/* (should this be norm of (A,B) or (AI,BI)?) */
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = dlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
1]);
/* Do tests (1) to (4) */
dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], result);
dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
/* Do tests (5) and (6): check Schur form of A and compare */
/* eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.;
result[4] = 0.;
result[5] = 0.;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)), d__7 = max(
d__7,d__8), d__8 = (d__3 = ai[j + j * ai_dim1], abs(d__3))
;
/* Computing MAX */
d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5)), d__9 = max(
d__9,d__10), d__10 = (d__6 = bi[j + j * bi_dim1], abs(
d__6));
temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1], abs(d__1)) /
max(d__7,d__8) + (d__4 = beta[j] - bi[j + j * bi_dim1],
abs(d__4)) / max(d__9,d__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai[j + 1 + j * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai[j + (j - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 + i1 * bi_dim1],
lda, &beta[j], &alphar[j], &alphai[j], &temp2, &iinfo)
;
if (iinfo >= 3) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.;
if (difest[1] == 0.) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
result[7] = max(d__1,d__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.;
if (pl[0] == 0.) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nout;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4) {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGSX */
} /* ddrgsx_ */
/* Subroutine */ int zdrvpb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
" \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002( '\002,a1,\002', '\002,a1,\002',"
" \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
",i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer ldab;
static char fact[1];
static integer ioff, mode, koff;
static doublereal amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact, nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
static integer kdval[4];
extern logical lsame_(char *, char *);
static char equed[1];
static integer nbmin;
static doublereal rcond, roldc, scond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static logical equil;
extern /* Subroutine */ int zpbt01_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zpbt02_(char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
), zpbt05_(char *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static integer iuplo, izero, i1, i2, k1, nerrs;
static logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zpbsv_(char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *), zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static char xtype[1];
extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *);
static integer kd, nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static logical prefac;
static integer iw, ku, nt;
static doublereal rcondc;
static logical nofact;
static char packit[1];
static integer iequed;
extern doublereal zlanhb_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *),
zlange_(char *, integer *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zlaqhb_(char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *, char *), alasvm_(char *, integer *,
integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
static doublereal ainvnm;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zpbequ_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *, integer *), zpbtrf_(char *, integer *, integer *, doublecomplex *,
integer *, 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 zpbtrs_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
integer *), zpbsvx_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
char *, doublereal *, doublecomplex *, integer *, doublecomplex *
, integer *, doublereal *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *),
zerrvx_(char *, integer *);
static integer lda, ikd, nkd;
/* Fortran I/O blocks */
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 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
=======
ZDRVPB tests the driver routines ZPBSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
S (workspace) DOUBLE PRECISION array, dimension (NMAX)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
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) {
zerrvx_(path, nout);
}
infoc_1.infot = 0;
kdval[0] = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* 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';
*(unsigned char *)packit = 'Q';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
} 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 L80;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L80;
}
if (! zerot || ! dotype[1]) {
/* 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, &kd, &kd, packit, &a[koff],
&ldab, &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 L80;
}
} 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;
zcopy_(&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);
zcopy_(&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);
zcopy_(&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;
zcopy_(&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__) {
i__5 = iw + i__;
work[i__5].r = 0., work[i__5].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;
zswap_(&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);
zswap_(&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);
zswap_(&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;
zswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
zlaipd_(&n, &a[kd + 1], &ldab, &c__0);
} else {
zlaipd_(&n, &a[1], &ldab, &c__0);
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
zlacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__4 = nfact;
for (ifact = 1; ifact <= i__4; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondc = 0.;
} else if (! lsame_(fact, "N")) {
/* Compute the condition number for comparison
with the value returned by ZPBSVX (FACT =
'N' reuses the condition number from the
previous iteration with FACT = 'F'). */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &
afac[1], &ldab);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
zpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
s[1], &scond, &amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
zlaqhb_(uplo, &n, &kd, &afac[1], &
ldab, &s[1], &scond, &amax,
equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in ZGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = zlanhb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
zpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
zlaset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)6, (
ftnlen)6);
zpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlange_("1", &n, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
&ldab);
/* Form an exact solution and set the right hand
side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (
ftnlen)6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
&lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
lda);
if (nofact) {
/* --- Test ZPBSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
i__5 = kd + 1;
zlacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "ZPBSV ", (ftnlen)6, (
ftnlen)6);
zpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from ZPBSV . */
if (info != izero) {
alaerh_(path, "ZPBSV ", &info, &izero,
uplo, &n, &n, &kd, &kd, nrhs, &
imat, &nfail, &nerrs, nout);
goto L40;
} else if (info != 0) {
goto L40;
}
/* Reconstruct matrix from factors and compute
residual. */
zpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
zpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did
not pass the threshold. */
i__5 = nt;
for (k = 1; k <= i__5; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___57.ciunit = *nout;
s_wsfe(&io___57);
do_fio(&c__1, "ZPBSV ", (ftnlen)6);
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 *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
L40:
;
}
/* --- Test ZPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
zlaset_("Full", &i__5, &n, &c_b47, &c_b47, &
afac[1], &ldab);
}
zlaset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y' */
zlaqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition
number and error bounds using ZPBSVX. */
s_copy(srnamc_1.srnamt, "ZPBSVX", (ftnlen)6, (
ftnlen)6);
zpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
afac[1], &ldab, equed, &s[1], &b[1], &lda,
&x[1], &lda, &rcond, &rwork[1], &rwork[*
nrhs + 1], &work[1], &rwork[(*nrhs << 1)
+ 1], &info);
/* Check the error code from ZPBSVX. */
if (info != izero) {
/* Writing concatenation */
i__7[0] = 1, a__1[0] = fact;
i__7[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
alaerh_(path, "ZPBSVX", &info, &izero, ch__1,
&n, &n, &kd, &kd, nrhs, &imat, &nfail,
&nerrs, nout);
goto L60;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and
compute residual. */
zpbt01_(uplo, &n, &kd, &a[1], &ldab, &
afac[1], &ldab, &rwork[(*nrhs <<
1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
zpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&x[1], &lda, &work[1], &lda, &rwork[(*
nrhs << 1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &rcondc, &result[2]);
} else {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
lda, &roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
zpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
&b[1], &lda, &x[1], &lda, &xact[1], &
lda, &rwork[1], &rwork[*nrhs + 1], &
result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from ZPBSVX with the computed
value in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not
pass the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___60.ciunit = *nout;
s_wsfe(&io___60);
do_fio(&c__1, "ZPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "ZPBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kd, (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;
}
/* L50: */
}
nrun = nrun + 7 - k1;
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* L100: */
}
/* L110: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPB */
} /* zdrvpb_ */
/* Subroutine */ int sdrvge_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
real *s, real *work, real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test(\002,i2,\002) =\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,"
"\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
real r__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
char dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc;
extern /* Subroutine */ int sget01_(integer *, integer *, real *, integer
*, real *, integer *, integer *, real *, real *);
integer nimat;
real roldi;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *);
real anorm;
integer itran;
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *);
logical equil;
real roldo;
extern /* Subroutine */ int sget07_(char *, integer *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, real *, real *);
char trans[1];
integer izero, nerrs;
extern /* Subroutine */ int sgesv_(integer *, integer *, real *, integer *
, integer *, real *, integer *, integer *);
integer lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
real colcnd;
extern doublereal slamch_(char *);
real rcondc;
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
logical nofact;
integer iequed;
extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, char *);
real rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
real cndnum, anormi, rcondo, ainvnm;
extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *);
logical trfcon;
real anormo, rowcnd;
extern /* Subroutine */ int sgetrf_(integer *, integer *, real *, integer
*, integer *, integer *), sgetri_(integer *, real *, integer *,
integer *, real *, integer *, integer *), slacpy_(char *, integer
*, integer *, real *, integer *, real *, integer *),
slarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, integer *, integer *);
extern doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
extern /* Subroutine */ int 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 *
), xlaenv_(integer *, integer *);
real result[7];
extern /* Subroutine */ int sgesvx_(char *, char *, integer *, integer *,
real *, integer *, real *, integer *, integer *, char *, real *,
real *, real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *, integer *);
real rpvgrw;
extern /* Subroutine */ int serrvx_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___68 = { 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 */
/* ======= */
/* SDRVGE tests the driver routines SGESV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) REAL array, dimension (NMAX*NMAX) */
/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (2*NMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (2*NRHS+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;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--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, "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 */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L80;
}
/* Set up parameters with SLATB4 and generate a test matrix */
/* with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)6, (ftnlen)6);
slatms_(&n, &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, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L80;
}
/* 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 = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L20: */
}
} else {
i__3 = n - izero + 1;
slaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
lda);
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
slacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (! nofact) {
/* Compute the condition number for comparison with */
/* the value returned by SGESVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
slacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
sgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
&rowcnd, &colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R"))
{
rowcnd = 0.f;
colcnd = 1.f;
} else if (lsame_(equed, "C")) {
rowcnd = 1.f;
colcnd = 0.f;
} else if (lsame_(equed, "B")) {
rowcnd = 0.f;
colcnd = 0.f;
}
/* Equilibrate the matrix. */
slaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
1], &rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the non-equilibrated */
/* system for use in SGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = slange_("1", &n, &n, &afac[1], &lda, &rwork[
1]);
anormi = slange_("I", &n, &n, &afac[1], &lda, &rwork[
1]);
/* Factor the matrix A. */
sgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
/* Form the inverse of A. */
slacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
lwork = *nmax * max(3,*nrhs);
sgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
&info);
/* Compute the 1-norm condition number of A. */
ainvnm = slange_("1", &n, &n, &a[1], &lda, &rwork[1]);
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of A. */
ainvnm = slange_("I", &n, &n, &a[1], &lda, &rwork[1]);
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)6, (ftnlen)
6);
slarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact && itran == 1) {
/* --- Test SGESV --- */
/* Compute the LU factorization of the matrix and */
/* solve the system. */
slacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
lda);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "SGESV ", (ftnlen)6, (
ftnlen)6);
sgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
&lda, &info);
/* Check error code from SGESV . */
if (info != izero) {
alaerh_(path, "SGESV ", &info, &izero, " ", &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
}
/* Reconstruct matrix from factors and compute */
/* residual. */
sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
sget02_("No transpose", &n, &n, nrhs, &a[1], &
lda, &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, "SGESV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
}
/* --- Test SGESVX --- */
if (! prefac) {
slaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
slaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
slaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using SGESVX. */
s_copy(srnamc_1.srnamt, "SGESVX", (ftnlen)6, (ftnlen)
6);
sgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check the error code from SGESVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SGESVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
}
/* Compare WORK(1) from SGESVX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info != 0) {
rpvgrw = slantr_("M", "U", "N", &info, &info, &
afac[1], &lda, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", &n, &info, &a[1], &lda,
&work[1]) / rpvgrw;
}
} else {
rpvgrw = slantr_("M", "U", "N", &n, &n, &afac[1],
&lda, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", &n, &n, &a[1], &lda, &
work[1]) / rpvgrw;
}
}
result[6] = (r__1 = rpvgrw - work[1], dabs(r__1)) /
dmax(work[1],rpvgrw) / slamch_("E")
;
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
sget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
sget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from SGESVX with the computed value */
/* in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___62.ciunit = *nout;
s_wsfe(&io___62);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L40: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___63.ciunit = *nout;
s_wsfe(&io___63);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___64.ciunit = *nout;
s_wsfe(&io___64);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___66.ciunit = *nout;
s_wsfe(&io___66);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___67.ciunit = *nout;
s_wsfe(&io___67);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
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();
} else {
io___68.ciunit = *nout;
s_wsfe(&io___68);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* L50: */
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVGE */
} /* sdrvge_ */
/* Subroutine */ int sdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, real *a, integer *lda, real *b, real *s, real *t, real *s2,
real *t2, real *q, integer *ldq, real *z__, real *alphr1, real *
alphi1, real *beta1, real *alphr2, real *alphi2, real *beta2, real *
vl, real *vr, real *work, integer *lwork, real *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 SDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 SDRVGG: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(\002 SDRVGG: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 SDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
"oblem driver\002)";
static char fmt_9994[] = "(\002 Matrix types (see SDRVGG for details):"
" \002)";
static char fmt_9993[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9992[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
" 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
"I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double r_sign(real *, real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
real ulp;
integer iadd, nmax;
real temp1, temp2;
logical badnn;
real dumma[4];
integer iinfo;
real rmagn[4];
extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *), sget52_(logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
real *), sgegv_(char *, char *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, integer *),
sget53_(real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *);
integer nmats, jsize, nerrs, jtype, ntest;
extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, integer *
, real *, integer *);
logical ilabad;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
real safmin;
integer ioldsd[4];
real safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
real ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGG checks the nonsymmetric generalized eigenvalue driver */
/* routines. */
/* T T T */
/* SGEGS factors A and B as Q S Z and Q T Z , where means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
/* eigenvalue problem */
/* det( A - w(j) B ) = 0 */
/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
/* problem */
/* det( m(j) A - B ) = 0 */
/* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), the matrix L whose columns contain the */
/* generalized left eigenvectors l, and the matrix R whose columns */
/* contain the generalized right eigenvectors r for the pair (A,B). */
/* When SDRVGG is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed and compared with the threshhold THRESH: */
/* Results from SGEGS: */
/* T */
/* (1) | A - Q S Z | / ( |A| n ulp ) */
/* T */
/* (2) | B - Q T Z | / ( |B| n ulp ) */
/* T */
/* (3) | I - QQ | / ( n ulp ) */
/* T */
/* (4) | I - ZZ | / ( n ulp ) */
/* (5) maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th eigenvalue. */
/* Results from SGEGV: */
/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* Test Matrices */
/* ---- -------- */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* SDRVGG does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, SDRVGG */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to SDRVGG to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* THRSHN (input) REAL */
/* Threshhold for reporting eigenvector normalization error. */
/* If the normalization of any eigenvector differs from 1 by */
/* more than THRSHN*ulp, then a special error message will be */
/* printed. (This is handled separately from the other tests, */
/* since only a compiler or programming error should cause an */
/* error message, at least if THRSHN is at least 5--10.) */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, T, S2, and T2. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) REAL array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by SGEGS. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) REAL array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by SGEGS. */
/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from A by SGEGV. This will be the */
/* Schur form of some matrix related to A, but will not, in */
/* general, be the same as S. */
/* T2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from B by SGEGV. This will be the */
/* Schur form of some matrix related to B, but will not, in */
/* general, be the same as T. */
/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by SGEGS. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q, Z, VL, and VR. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) REAL array of */
/* dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by SGEGS. */
/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
/* BETA1 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGS. */
/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* ALPHR2 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI2 (workspace) REAL array, dimension (max(NN)) */
/* BETA2 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGV. */
/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* VL (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block lower triangular) left eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* VR (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block upper triangular) right eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
/* "k" is the sum of the blocksize and number-of-shifts for */
/* SHGEQZ, and NB is the greatest of the blocksizes for */
/* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the */
/* number-of-shifts are retrieved through calls to ILAENV.) */
/* RESULT (output) REAL array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alphr1;
--alphi1;
--beta1;
--alphr2;
--alphi2;
--beta2;
--work;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number */
/* of shifts are monotone increasing functions of N. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "SORGQR",
" ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
ns = ilaenv_(&c__4, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = (nmax << 1) + max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L160;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 15; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B */
/* Description of control parameters: */
/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* IASIGN: 1 if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number, =2 if */
/* randomly chosen diagonal blocks are to be rotated */
/* to form 2x2 blocks. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
lda);
}
} else {
in = n;
}
slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a[iadd + iadd * a_dim1] = 1.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
lda);
}
} else {
in = n;
}
slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b42, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b[iadd + iadd * b_dim1] = 1.f;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = r_sign(&c_b42, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.f;
i__4 = n + 1 - jc;
slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = r_sign(&c_b42, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.f;
/* L50: */
}
q[n + n * q_dim1] = 1.f;
work[n] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 3] = r_sign(&c_b42, &r__1);
z__[n + n * z_dim1] = 1.f;
work[n * 2] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 4] = r_sign(&c_b42, &r__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * a[jr + jc * a_dim1];
b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * b[jr + jc * b_dim1];
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
/* Call SGEGS to compute H, T, Q, Z, alpha, and beta. */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
sgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "SGEGS", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 4;
/* Do tests 1--4 */
sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
;
sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
;
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
;
/* Do test 5: compare eigenvalues with diagonals. */
/* Also check Schur form of A. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi1[j] == 0.f) {
/* Computing MAX */
r__7 = safmin, r__8 = (r__2 = alphr1[j], dabs(r__2)),
r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j *
s_dim1], dabs(r__3));
/* Computing MAX */
r__9 = safmin, r__10 = (r__5 = beta1[j], dabs(r__5)),
r__9 = max(r__9,r__10), r__10 = (r__6 = t[j + j *
t_dim1], dabs(r__6));
temp2 = ((r__1 = alphr1[j] - s[j + j * s_dim1], dabs(r__1)
) / dmax(r__7,r__8) + (r__4 = beta1[j] - t[j + j *
t_dim1], dabs(r__4)) / dmax(r__9,r__10)) / ulp;
if (j < n) {
if (s[j + 1 + j * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (j > 1) {
if (s[j + (j - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
} else {
if (alphi1[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
} else if (i1 > 1) {
if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (! ilabad) {
sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
j], &temp2, &iinfo);
if (iinfo >= 3) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L120: */
}
result[5] = temp1;
/* Call SGEGV to compute S2, T2, VL, and VR, do tests. */
/* Eigenvalues and Eigenvectors */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
sgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
vr[vr_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 7;
/* Do Tests 6 and 7 */
sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Check form of Complex eigenvalues. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi2[j] > 0.f) {
if (j == n) {
ilabad = TRUE_;
} else if (alphi2[j + 1] >= 0.f) {
ilabad = TRUE_;
}
} else if (alphi2[j] < 0.f) {
if (j == 1) {
ilabad = TRUE_;
} else if (alphi2[j - 1] <= 0.f) {
ilabad = TRUE_;
}
}
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L130: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L140:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "SGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
} else {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
}
/* L150: */
}
L160:
;
}
/* L170: */
}
/* Summary */
alasvm_("SGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of SDRVGG */
} /* sdrvgg_ */
/* Subroutine */ int zdrgvx_(integer *nsize, doublereal *thresh, integer *nin,
integer *nout, doublecomplex *a, integer *lda, doublecomplex *b,
doublecomplex *ai, doublecomplex *bi, doublecomplex *alpha,
doublecomplex *beta, doublecomplex *vl, doublecomplex *vr, integer *
ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal
*s, doublereal *dtru, doublereal *dif, doublereal *diftru,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *
iwork, integer *liwork, doublereal *result, logical *bwork, integer *
info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
"WY=\002,i5)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
"or\002,\002 problem driver\002)";
static char fmt_9995[] = "(\002 Matrix types: \002,/)";
static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
" \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
"\002 YH and X are left and right eigenvectors. \002,/)";
static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
"tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
" \002,/\002 YH and X are left and right eigenvectors. \002,/)"
;
static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
"pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
"ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
" max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
" ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
"Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
"DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
"ors\002,/)";
static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,1p,d10.3)";
static char fmt_9987[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
")\002)";
static char fmt_9986[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
"le #\002,i2,\002)\002)";
static char fmt_9996[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwa, iwb;
doublereal ulp;
integer iwx, iwy, nmax, linfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
integer nerrs;
doublereal ratio1, ratio2, thrsh2;
extern /* Subroutine */ int zlatm6_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal abnorm;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublecomplex weight[5];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer minwrk, maxwrk, iptype;
extern /* Subroutine */ int zggevx_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublecomplex *, integer *, doublereal *, integer *,
logical *, integer *);
doublereal ulpinv;
integer nptknt, ntestt;
/* Fortran I/O blocks */
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___35 = { 0, 0, 1, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGVX checks the nonsymmetric generalized eigenvalue problem */
/* expert driver ZGGEVX. */
/* ZGGEVX computes the generalized eigenvalues, (optionally) the left */
/* and/or right eigenvectors, (optionally) computes a balancing */
/* transformation to improve the conditioning, and (optionally) */
/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
/* When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs */
/* are generated by the subroutine DLATM6 and test the driver ZGGEVX. */
/* The test matrices have the known exact condition numbers for */
/* eigenvalues. For the condition numbers of the eigenvectors */
/* corresponding the first and last eigenvalues are also know */
/* ``exactly'' (see ZLATM6). */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH. */
/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* (3) The condition number S(i) of eigenvalues computed by ZGGEVX */
/* differs less than a factor THRESH from the exact S(i) (see */
/* ZLATM6). */
/* (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH */
/* from the exact value (for the 1st and 5th vectors only). */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 2+a 0 0 0 0 1 0 0 0 */
/* 0 0 3+a 0 0 0 0 1 0 0 */
/* 0 0 0 4+a 0 0 0 0 1 0 */
/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
/* 1 1 0 0 0 0 1 0 0 0 */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1+a 1+b 0 0 0 1 0 */
/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
/* In both cases the same inverse(YH) and inverse(X) are used to compute */
/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
/* 0 1 -y y -y 0 1 x -x -x */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1 0 0 0 0 1 0 */
/* 0 0 0 0 1, 0 0 0 0 1 , where */
/* a, b, x and y will have all values independently of each other from */
/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The number of sizes of matrices to use. NSIZE must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIN will be */
/* tested. If it is not zero, then N = 5. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
/* It must be at least 1 and at least NSIZE. */
/* B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of A, modified by ZGGEVX. */
/* BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of B, modified by ZGGEVX. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* BETA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* On exit, ALPHA/BETA are the eigenvalues. */
/* VL (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VL holds the left eigenvectors computed by ZGGEVX. */
/* VR (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VR holds the right eigenvectors computed by ZGGEVX. */
/* ILO (output/workspace) INTEGER */
/* IHI (output/workspace) INTEGER */
/* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* S (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIF (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* Leading dimension of IWORK. LIWORK >= N+2. */
/* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
vr_dim1 = *lda;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *lda;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alpha;
--beta;
--lscale;
--rscale;
--s;
--dtru;
--dif;
--diftru;
--work;
--rwork;
--iwork;
--result;
--bwork;
/* Function Body */
*info = 0;
nmax = 5;
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < nmax) {
*info = -6;
} else if (*liwork < nmax + 2) {
*info = -26;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = (nmax << 1) * (nmax + 1);
maxwrk = nmax * (ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &c__1, &nmax, &
c__0) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGVX", &i__1);
return 0;
}
n = 5;
ulp = dlamch_("P");
ulpinv = 1. / ulp;
thrsh2 = *thresh * 10.;
nerrs = 0;
nptknt = 0;
ntestt = 0;
if (*nsize == 0) {
goto L90;
}
/* Parameters used for generating test matrices. */
d__1 = sqrt(sqrt(ulp));
z__1.r = d__1, z__1.i = 0.;
weight[0].r = z__1.r, weight[0].i = z__1.i;
weight[1].r = .1, weight[1].i = 0.;
weight[2].r = 1., weight[2].i = 0.;
z_div(&z__1, &c_b11, &weight[1]);
weight[3].r = z__1.r, weight[3].i = z__1.i;
z_div(&z__1, &c_b11, weight);
weight[4].r = z__1.r, weight[4].i = z__1.i;
for (iptype = 1; iptype <= 2; ++iptype) {
for (iwa = 1; iwa <= 5; ++iwa) {
for (iwb = 1; iwb <= 5; ++iwb) {
for (iwx = 1; iwx <= 5; ++iwx) {
for (iwy = 1; iwy <= 5; ++iwy) {
/* generated a pair of test matrix */
zlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
b_offset], &vr[vr_offset], lda, &vl[vl_offset]
, lda, &weight[iwa - 1], &weight[iwb - 1], &
weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
diftru[1]);
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
, lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
, lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
vl_offset], lda, &vr[vr_offset], lda, ilo,
ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
s[1], &dif[1], &work[1], lwork, &rwork[1], &
iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
goto L30;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
&n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &
rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
&work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
, &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
d__4 = (d__2 = s[i__] / dtru[i__],
abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L10: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)),
d__4 = (d__2 = dif[1] / diftru[1], abs(
d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)),
d__4 = (d__2 = dif[5] / diftru[5], abs(
d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2 && j >= 4 || result[j] >=
*thresh && j <= 3) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___29.ciunit = *nout;
s_wsfe(&io___29);
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
/* Tests performed */
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
/* L40: */
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
goto L150;
L90:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
io___35.ciunit = *nin;
i__1 = s_rsle(&io___35);
if (i__1 != 0) {
goto L150;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L150;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L150;
}
if (n == 0) {
goto L150;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___36.ciunit = *nin;
s_rsle(&io___36);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L100: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___37.ciunit = *nin;
s_rsle(&io___37);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L110: */
}
io___38.ciunit = *nin;
s_rsle(&io___38);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
}
e_rsle();
io___39.ciunit = *nin;
s_rsle(&io___39);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
;
}
e_rsle();
++nptknt;
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
&alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
&work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L140;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
i__] / dtru[i__], abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L120: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
diftru[1], abs(d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
diftru[5], abs(d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___44.ciunit = *nout;
s_wsfe(&io___44);
e_wsfe();
/* Tests performed */
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* L130: */
}
L140:
goto L90;
L150:
/* Summary */
alasvm_("ZXV", nout, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGVX */
} /* zdrgvx_ */
/* Subroutine */ int cdrgev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *nounit,
complex *a, integer *lda, complex *b, complex *s, complex *t, complex
*q, integer *ldq, complex *z__, complex *qe, integer *ldqe, complex *
alpha, complex *beta, complex *alpha1, complex *beta1, complex *work,
integer *lwork, real *rwork, real *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 CDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see CDRGEV for details):"
" \002)";
static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_sign(real *, real *), c_abs(complex *);
void r_cnjg(complex *, complex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, real *, real *), cggev_(char *, char *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
static real rmagn[4];
static complex ctemp;
static integer nmats, jsize, nerrs, jtype, n1;
extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
integer *, logical *, real *, real *, real *, integer *, integer *
, complex *, integer *), cunm2r_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *);
static integer jc, nb, in;
extern /* Subroutine */ int slabad_(real *, real *);
static integer jr;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
static real safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *);
static integer minwrk, maxwrk;
static real ulpinv;
static integer mtypes, ntestt;
static real ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1
#define qe_ref(a_1,a_2) qe[qe_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CDRGEV checks the nonsymmetric generalized eigenvalue problem driver
routine CGGEV.
CGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
generalized eigenvalues and, optionally, the left and right
eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is reasonalbe
interpretation for beta=0, and even for both being zero.
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such that
(A - wB) * r = 0. A left generalized eigenvector is a vector l such
that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
When CDRGEV is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, a pair of matrices (A, B) will be generated
and used for testing. For each matrix pair, the following tests
will be performed and compared with the threshhold THRESH.
Results from CGGEV:
(1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
| VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
where VL**H is the conjugate-transpose of VL.
(2) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
| (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
(4) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both l and r
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and r, or only W and l are
computed.
(6) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both l
and r are computed, and VL(partial) denotes the result
when only l is computed.
(7) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both l
and r are also computed, and VR(partial) denotes the result
when only l is computed.
Test Matrices
---- --------
The sizes of the test matrices are specified by an array
NN(1:NSIZES); the value of each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) ( 0, 0 ) (a pair of zero matrices)
(2) ( I, 0 ) (an identity and a zero matrix)
(3) ( 0, I ) (an identity and a zero matrix)
(4) ( I, I ) (a pair of identity matrices)
t t
(5) ( J , J ) (a pair of transposed Jordan blocks)
t ( I 0 )
(6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
( 0 I ) ( 0 J )
and I is a k x k identity and J a (k+1)x(k+1)
Jordan block; k=(N-1)/2
(7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
matrix with those diagonal entries.)
(8) ( I, D )
(9) ( big*D, small*I ) where "big" is near overflow and small=1/big
(10) ( small*D, big*I )
(11) ( big*I, small*D )
(12) ( small*I, big*D )
(13) ( big*D, big*I )
(14) ( small*D, small*I )
(15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
t t
(16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
(17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
with random O(1) entries above the diagonal
and diagonal entries diag(T1) =
( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
( 0, N-3, N-4,..., 1, 0, 0 )
(18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
s = machine precision.
(19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
N-5
(20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
(21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
where r1,..., r(N-4) are random.
(22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
diag(T2) = ( 0, 1, ..., 1, 0, 0 )
(26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
matrices.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
CDRGES does nothing. NSIZES >= 0.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. NN >= 0.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, CDRGEV
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to CDRGES to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IERR not equal to 0.)
A (input/workspace) COMPLEX array, dimension(LDA, max(NN))
Used to hold the original A matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
LDA (input) INTEGER
The leading dimension of A, B, S, and T.
It must be at least 1 and at least max( NN ).
B (input/workspace) COMPLEX array, dimension(LDA, max(NN))
Used to hold the original B matrix. Used as input only
if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
DOTYPE(MAXTYP+1)=.TRUE.
S (workspace) COMPLEX array, dimension (LDA, max(NN))
The Schur form matrix computed from A by CGGEV. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) COMPLEX array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by CGGEV.
Q (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (left) eigenvectors matrix computed by CGGEV.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by CGGEV.
QE (workspace) COMPLEX array, dimension( LDQ, max(NN) )
QE holds the computed right or left eigenvectors.
LDQE (input) INTEGER
The leading dimension of QE. LDQE >= max(1,max(NN)).
ALPHA (workspace) COMPLEX array, dimension (max(NN))
BETA (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGGEV.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
ALPHA1 (workspace) COMPLEX array, dimension (max(NN))
BETA1 (workspace) COMPLEX array, dimension (max(NN))
Like ALPHAR, ALPHAI, BETA, these arrays contain the
eigenvalues of A and B, but those computed when CGGEV only
computes a partial eigendecomposition, i.e. not the
eigenvalues and left and right eigenvectors.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. LWORK >= N*(N+1)
RWORK (workspace) REAL array, dimension (8*N)
Real workspace.
RESULT (output) REAL array, dimension (2)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code. INFO is the
absolute value of the INFO value returned.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1 * 1;
qe -= qe_offset;
--alpha;
--beta;
--alpha1;
--beta1;
--work;
--rwork;
--result;
/* Function Body
Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = nmax * (nmax + 1);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
= nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRGEV", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = slamch_("Precision");
safmin = slamch_("Safe minimum");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Generate test matrices A and B
Description of control parameters:
KCLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to CLATM4 for computing A.
KAZERO: the pattern of zeros on the diagonal for A:
=1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
=4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
=6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
non-zero entries.)
KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
=2: large, =3: small.
LASIGN: .TRUE. if the diagonal elements of A are to be
multiplied by a random magnitude 1 number.
KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B.
KTRIAN: =0: don't fill in the upper triangle, =1: do.
KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L100;
}
ierr = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
i__3 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
i__3 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations
Generate Q, Z as Householder transformations times
a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
i__5 = q_subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
q[i__5].r = q__1.r, q[i__5].i = q__1.i;
i__5 = z___subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
/* L30: */
}
i__4 = n + 1 - jc;
clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
r__2 = q[i__5].r;
r__1 = r_sign(&c_b28, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1.f, q[i__4].i = 0.f;
i__4 = n + 1 - jc;
clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
r__2 = z__[i__5].r;
r__1 = r_sign(&c_b28, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1.f, z__[i__4].i = 0.f;
/* L40: */
}
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1.f, q[i__3].i = 0.f;
i__3 = n;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n * 3;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1.f, z__[i__3].i = 0.f;
i__3 = n << 1;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n << 2;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = a_subscr(jr, jc);
q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
q__1.i = q__2.r * a[i__7].i + q__2.i * a[
i__7].r;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = b_subscr(jr, jc);
q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
q__1.i = q__2.r * b[i__7].i + q__2.i * b[
i__7].r;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L50: */
}
/* L60: */
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.f;
/* L110: */
}
/* Call CGGEV to compute eigenvalues and eigenvectors. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
/* Do the tests (1) and (2) */
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[1]);
if (result[2] > *thresh) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do the tests (3) and (4) */
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[3]);
if (result[4] > *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Do test (5) */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "CGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do test (6): Compute eigenvalues and left eigenvectors,
and test them */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
, ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "CGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = q_subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* Do test (7): Compute eigenvalues and right eigenvectors,
and test them */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
ldqe, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(ierr);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = z___subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
.i) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 9; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, "CGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
} else {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("CGV", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CDRGEV */
} /* cdrgev_ */
/* 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_ */
