/* Subroutine */ int cdrvpb_(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 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 */
integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
ldab;
char fact[1];
integer ioff, mode, koff;
real amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
integer nfail, iseed[4], nfact;
extern /* Subroutine */ int cpbt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *),
cpbt02_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *), cpbt05_(char *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *, real *);
integer kdval[4];
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
extern doublereal sget06_(real *, real *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cpbsv_(char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, integer *);
logical equil;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer iuplo, 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 clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *), clange_(char *, integer *,
integer *, complex *, integer *, real *);
extern /* Subroutine */ int claqhb_(char *, integer *, integer *, complex
*, integer *, real *, real *, real *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *), claipd_(integer *,
complex *, integer *, integer *);
logical prefac;
real rcondc;
logical nofact;
char packit[1];
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 *), cpbequ_(char *, integer *, integer
*, complex *, integer *, real *, real *, real *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
*);
real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *), cpbtrf_(char *, integer *, integer *, complex *,
integer *, integer *);
real ainvnm;
extern /* Subroutine */ int cpbtrs_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, integer *),
xlaenv_(integer *, integer *), cpbsvx_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
char *, real *, complex *, integer *, complex *, integer *, real
*, real *, real *, complex *, real *, integer *), cerrvx_(char *, integer *);
real result[6];
/* 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.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVPB tests the driver routines CPBSV 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) */
/* 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. 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, "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) {
cerrvx_(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 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, &kd, &kd, packit, &a[koff],
&ldab, &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 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;
ccopy_(&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);
ccopy_(&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);
ccopy_(&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;
ccopy_(&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.f, work[i__5].i = 0.f;
/* 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;
cswap_(&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);
cswap_(&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);
cswap_(&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;
cswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[kd + 1], &ldab, &c__0);
} else {
claipd_(&n, &a[1], &ldab, &c__0);
}
/* Save a copy of the matrix A in ASAV. */
i__4 = kd + 1;
clacpy_("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.f;
} else if (! lsame_(fact, "N")) {
/* Compute the condition number for comparison */
/* with the value returned by CPBSVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__5 = kd + 1;
clacpy_("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. */
cpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
s[1], &scond, &amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhb_(uplo, &n, &kd, &afac[1], &
ldab, &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 = clanhb_("1", uplo, &n, &kd, &afac[1],
&ldab, &rwork[1]);
/* Factor the matrix A. */
cpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Form the inverse of A. */
claset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
&lda);
s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)6, (
ftnlen)6);
cpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clange_("1", &n, &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. */
i__5 = kd + 1;
clacpy_("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, "CLARHS", (ftnlen)6, (
ftnlen)6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
nrhs, &a[1], &ldab, &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 CPBSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
i__5 = kd + 1;
clacpy_("Full", &i__5, &n, &a[1], &ldab, &
afac[1], &ldab);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "CPBSV ", (ftnlen)6, (
ftnlen)6);
cpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
x[1], &lda, &info);
/* Check error code from CPBSV . */
if (info != izero) {
alaerh_(path, "CPBSV ", &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. */
cpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
&ldab, &rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
cpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &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__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, "CPBSV ", (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(real));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
L40:
;
}
/* --- Test CPBSVX --- */
if (! prefac) {
i__5 = kd + 1;
claset_("Full", &i__5, &n, &c_b47, &c_b47, &
afac[1], &ldab);
}
claset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y' */
claqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
scond, &amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using CPBSVX. */
s_copy(srnamc_1.srnamt, "CPBSVX", (ftnlen)6, (
ftnlen)6);
cpbsvx_(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 CPBSVX. */
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, "CPBSVX", &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. */
cpbt01_(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. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &
work[1], &lda);
cpbt02_(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")) {
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. */
cpbt05_(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 CPBSVX 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___60.ciunit = *nout;
s_wsfe(&io___60);
do_fio(&c__1, "CPBSVX", (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(real));
e_wsfe();
} else {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "CPBSVX", (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(real));
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 CDRVPB */
} /* cdrvpb_ */
int chgeqz_(char *job, char *compq, char *compz, int *n,
int *ilo, int *ihi, complex *h__, int *ldh, complex *t,
int *ldt, complex *alpha, complex *beta, complex *q, int *ldq,
complex *z__, int *ldz, complex *work, int *lwork, float *
rwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
double r_imag(complex *);
void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
int *), c_sqrt(complex *, complex *);
/* Local variables */
float c__;
int j;
complex s, t1;
int jc, in;
complex u12;
int jr;
complex ad11, ad12, ad21, ad22;
int jch;
int ilq, ilz;
float ulp;
complex abi22;
float absb, atol, btol, temp;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
float temp2;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
complex ctemp;
int iiter, ilast, jiter;
float anorm, bnorm;
int maxit;
complex shift;
float tempr;
complex ctemp2, ctemp3;
int ilazr2;
float ascale, bscale;
complex signbc;
extern double slamch_(char *), clanhs_(char *, int *,
complex *, int *, float *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *);
float safmin;
extern int xerbla_(char *, int *);
complex eshift;
int ilschr;
int icompq, ilastm;
complex rtdisc;
int ischur;
int ilazro;
int icompz, ifirst, ifrstm, istart;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
/* where H is an upper Hessenberg matrix and T is upper triangular, */
/* using the single-shift QZ method. */
/* Matrix pairs of this type are produced by the reduction to */
/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
/* as computed by CGGHRD. */
/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
/* also reduced to generalized Schur form, */
/* H = Q*S*Z**H, T = Q*P*Z**H, */
/* where Q and Z are unitary matrices and S and P are upper triangular. */
/* Optionally, the unitary matrix Q from the generalized Schur */
/* factorization may be postmultiplied into an input matrix Q1, and the */
/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
/* Schur factorization of (A,B): */
/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
/* (equivalently, of (A,B)) are computed as a pair of complex values */
/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
/* A*x = lambda*B*x */
/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
/* alternate form of the GNEP */
/* mu*A*y = B*y. */
/* The values of alpha and beta for the i-th eigenvalue can be read */
/* directly from the generalized Schur form: alpha = S(i,i), */
/* beta = P(i,i). */
/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
/* pp. 241--256. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': Compute eigenvalues only; */
/* = 'S': Computer eigenvalues and the Schur form. */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': Left Schur vectors (Q) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Q */
/* of left Schur vectors of (H,T) is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry and */
/* the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Right Schur vectors (Z) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Z */
/* of right Schur vectors of (H,T) is returned; */
/* = 'V': Z must contain a unitary matrix Z1 on entry and */
/* the product Z1*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrices H, T, Q, and Z. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of H which are in */
/* Hessenberg form. It is assumed that A is already upper */
/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
/* H (input/output) COMPLEX array, dimension (LDH, N) */
/* On entry, the N-by-N upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular */
/* matrix S from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of H matches that of S, but */
/* the rest of H is unspecified. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX( 1, N ). */
/* T (input/output) COMPLEX array, dimension (LDT, N) */
/* On entry, the N-by-N upper triangular matrix T. */
/* On exit, if JOB = 'S', T contains the upper triangular */
/* matrix P from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of T matches that of P, but */
/* the rest of T is unspecified. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX( 1, N ). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
/* factorization. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The float non-negative scalars beta that define the */
/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
/* Schur factorization. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* left Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If COMPQ='V' or 'I', then LDQ >= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* right Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If COMPZ='V' or 'I', then LDZ >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO+1,...,N should be correct. */
/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO-N+1,...,N should be correct. */
/* Further Details */
/* =============== */
/* We assume that complex ABS works as long as its value is less than */
/* overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode JOB, COMPQ, COMPZ */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(job, "E")) {
ilschr = FALSE;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = MAX(1,*n);
work[1].r = (float) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*ldh < *n) {
*info = -8;
} else if (*ldt < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = slamch_("S");
ulp = slamch_("E") * slamch_("B");
anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * anorm;
atol = MAX(r__1,r__2);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * bnorm;
btol = MAX(r__1,r__2);
ascale = 1.f / MAX(safmin,anorm);
bscale = 1.f / MAX(safmin,bnorm);
/* Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP */
/* Initialize dynamic indices */
/* Eigenvalues ILAST+1:N have been found. */
/* Column operations modify rows IFRSTM:whatever */
/* Row operations modify columns whatever:ILASTM */
/* If only eigenvalues are being computed, then */
/* IFRSTM is the row of the last splitting row above row ILAST; */
/* this is always at least ILO. */
/* IITER counts iterations since the last eigenvalue was found, */
/* to tell when to use an extraordinary shift. */
/* MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible. */
/* Two tests: */
/* 1: H(j,j-1)=0 or j=ILO */
/* 2: T(j,j)=0 */
/* Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = ilast + (ilast - 1) * h_dim1;
if ((r__1 = h__[i__2].r, ABS(r__1)) + (r__2 = r_imag(&h__[ilast
+ (ilast - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
goto L60;
}
}
if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for H(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE;
} else {
i__3 = j + (j - 1) * h_dim1;
if ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j
+ (j - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__3 = j + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
ilazro = TRUE;
} else {
ilazro = FALSE;
}
}
/* Test 2: for T(j,j)=0 */
if (c_abs(&t[j + j * t_dim1]) < btol) {
i__3 = j + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE;
if (! ilazro) {
i__3 = j + (j - 1) * h_dim1;
i__4 = j + 1 + j * h_dim1;
i__5 = j + j * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
h__[j + (j - 1) * h_dim1]), ABS(r__2))) * (
ascale * ((r__3 = h__[i__4].r, ABS(r__3)) + (
r__4 = r_imag(&h__[j + 1 + j * h_dim1]), ABS(
r__4)))) <= ((r__5 = h__[i__5].r, ABS(r__5)) + (
r__6 = r_imag(&h__[j + j * h_dim1]), ABS(r__6)))
* (ascale * atol)) {
ilazr2 = TRUE;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal */
/* element of B in the block is zero, split a 1x1 block off */
/* at the top. (I.e., at the J-th row/column) The leading */
/* diagonal element of the remainder can also be zero, so */
/* this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
s, &h__[jch + jch * h_dim1]);
i__4 = jch + 1 + jch * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = ilastm - jch;
crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
&s);
i__4 = ilastm - jch;
crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
if (ilazr2) {
i__4 = jch + (jch - 1) * h_dim1;
i__5 = jch + (jch - 1) * h_dim1;
q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
i__5].i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
}
ilazr2 = FALSE;
i__4 = jch + 1 + (jch + 1) * t_dim1;
if ((r__1 = t[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
t[jch + 1 + (jch + 1) * t_dim1]), ABS(r__2))
>= btol) {
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
/* Then process as in the case T(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + (jch + 1) * t_dim1;
ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
c__, &s, &t[jch + (jch + 1) * t_dim1]);
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
t[jch + 1 + (jch + 2) * t_dim1], ldt, &
c__, &s);
}
i__4 = ilastm - jch + 2;
crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
&s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
i__4 = jch + 1 + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
c__, &s, &h__[jch + 1 + jch * h_dim1]);
i__4 = jch + 1 + (jch - 1) * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = jch + 1 - ifrstm;
crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
;
i__4 = jch - ifrstm;
crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
;
if (ilz) {
crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
- 1) * z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J */
/* L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
/* 1x1 block. */
L50:
i__2 = ilast + ilast * h_dim1;
ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
ilast + ilast * h_dim1]);
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = ilast - ifrstm;
crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
ilast - 1) * h_dim1], &c__1, &c__, &s);
i__2 = ilast - ifrstm;
crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
1) * t_dim1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = c_abs(&t[ilast + ilast * t_dim1]);
if (absb > safmin) {
i__2 = ilast + ilast * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = ilast + ilast * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = ilast - ifrstm;
cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
i__2 = ilast + 1 - ifrstm;
cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
} else {
i__2 = ilast + ilast * h_dim1;
i__3 = ilast + ilast * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
}
} else {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = ilast;
i__3 = ilast + ilast * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = ilast;
i__3 = ilast + ilast * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step */
/* This iteration only involves rows/columns IFIRST:ILAST. We */
/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift. */
/* At this point, IFIRST < ILAST, and the diagonal elements of */
/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
/* magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
/* the bottom-right 2x2 block of A inv(B) which is nearest to */
/* the bottom-right element. */
/* We factor B as U*D, where U has unit diagonals, and */
/* compute (A*inv(D))*inv(U). */
i__2 = ilast - 1 + ilast * t_dim1;
q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
u12.r = q__1.r, u12.i = q__1.i;
i__2 = ilast - 1 + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad11.r = q__1.r, ad11.i = q__1.i;
i__2 = ilast + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad21.r = q__1.r, ad21.i = q__1.i;
i__2 = ilast - 1 + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad12.r = q__1.r, ad12.i = q__1.i;
i__2 = ilast + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad22.r = q__1.r, ad22.i = q__1.i;
q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
abi22.r = q__1.r, abi22.i = q__1.i;
q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t1.r = q__1.r, t1.i = q__1.i;
pow_ci(&q__4, &t1, &c__2);
q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
if (temp <= 0.f) {
q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
} else {
q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
}
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = ilast - 1 + ilast * h_dim1;
q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
c_div(&q__3, &q__4, &q__5);
r_cnjg(&q__2, &q__3);
q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
eshift.r = q__1.r, eshift.i = q__1.i;
shift.r = eshift.r, shift.i = eshift.i;
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = j + j * h_dim1;
q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
i__4 = j + j * t_dim1;
q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
temp = (r__1 = ctemp.r, ABS(r__1)) + (r__2 = r_imag(&ctemp),
ABS(r__2));
i__3 = j + 1 + j * h_dim1;
temp2 = ascale * ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&h__[j + 1 + j * h_dim1]), ABS(r__2)));
tempr = MAX(temp,temp2);
if (tempr < 1.f && tempr != 0.f) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = j + (j - 1) * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j + (
j - 1) * h_dim1]), ABS(r__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = ifirst + ifirst * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ifirst + ifirst * t_dim1;
q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
L90:
/* Do an implicit-shift QZ sweep. */
/* Initial Q */
i__2 = istart + 1 + istart * h_dim1;
q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = j + (j - 1) * h_dim1;
ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
h__[j + (j - 1) * h_dim1]);
i__3 = j + 1 + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = j + jc * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = j + 1 + jc * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = j + 1 + jc * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + 1 + jc * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + jc * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
i__4 = j + jc * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = j + 1 + jc * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
i__4 = j + 1 + jc * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = j + 1 + jc * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = j + jc * t_dim1;
t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + j * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = jr + (j + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + (j + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = jr + j * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = jr + (j + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = jr + j * q_dim1;
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = j + 1 + (j + 1) * t_dim1;
ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
1) * t_dim1]);
i__3 = j + 1 + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Computing MIN */
i__4 = j + 2;
i__3 = MIN(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = jr + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = jr + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = jr + j * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = jr + j * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = jr + (j + 1) * t_dim1;
t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * z_dim1;
q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
i__5 = jr + j * z_dim1;
q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * z_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * z_dim1;
q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
.r;
i__6 = jr + j * z_dim1;
q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * z_dim1;
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
L160:
/* L170: */
;
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
q__1.r = (float) (*n), q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CHGEQZ */
} /* chgeqz_ */
doublereal ctzt01_(integer *m, integer *n, complex *a, complex *af, integer *
lda, complex *tau, complex *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
real ret_val;
/* Local variables */
integer i__, j;
real norma;
real rwork[1];
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTZT01 returns */
/* || A - R*Q || / ( M * eps * ||A|| ) */
/* for an upper trapezoidal A that was factored with CTZRQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices A and AF. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and AF. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original upper trapezoidal M by N matrix A. */
/* AF (input) COMPLEX array, dimension (LDA,N) */
/* The output of CTZRQF for input matrix A. */
/* The lower triangle is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A and AF. */
/* TAU (input) COMPLEX array, dimension (M) */
/* Details of the Householder transformations as returned by */
/* CTZRQF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= m*n + m. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.f;
if (*lwork < *m * *n + *m) {
this_xerbla_("CTZT01", &c__8);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
norma = clange_("One-norm", m, n, &a[a_offset], lda, rwork);
/* Copy upper triangle R */
claset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = (j - 1) * *m + i__;
i__4 = i__ + j * af_dim1;
work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
/* L10: */
}
/* L20: */
}
/* R = R * P(1) * ... *P(m) */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *m + 1;
clatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
work[*m * *n + 1]);
/* L30: */
}
/* R = R - A */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
caxpy_(m, &c_b15, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
1], &c__1);
/* L40: */
}
ret_val = clange_("One-norm", m, n, &work[1], m, rwork);
ret_val /= slamch_("Epsilon") * (real) max(*m,*n);
if (norma != 0.f) {
ret_val /= norma;
}
return ret_val;
/* End of CTZT01 */
} /* ctzt01_ */
/* Subroutine */ int cdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, real *d__,
complex *e, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* 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, i__5;
real r__1, r__2;
/* 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;
integer 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 */
/* ======= */
/* CDRVPT tests CPTSV 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) COMPLEX array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* B (workspace) COMPLEX array, dimension (NMAX*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) */
/* 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, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
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];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = 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]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1].r = z__[2], e[1].i = 0.f;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0], e[i__3].i = 0.f;
d__[n] = z__[1];
} else {
i__3 = izero - 1;
e[i__3].r = z__[0], e[i__3].i = 0.f;
d__[izero] = z__[1];
i__3 = izero;
e[i__3].r = z__[2], e[i__3].i = 0.f;
}
}
/* 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].r;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0] = e[i__3].r;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} 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.f, e[i__3].i = 0.f;
i__3 = izero;
z__[2] = e[i__3].r;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 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) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
claptm_("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 CPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = clanht_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use CPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L50: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* 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 CPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
clacpy_("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, "CPTSV ", (ftnlen)32, (ftnlen)6);
cptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from CPTSV . */
if (info != izero) {
alaerh_(path, "CPTSV ", &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 ) */
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
lda, &work[1], &lda, &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___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "CPTSV ", (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 CPTSVX --- */
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;
i__4 = n + i__;
e[i__4].r = 0.f, e[i__4].i = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
claset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using CPTSVX. */
s_copy(srnamc_1.srnamt, "CPTSVX", (ftnlen)32, (ftnlen)6);
cptsvx_(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 CPTSVX. */
if (info != izero) {
alaerh_(path, "CPTSVX", &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;
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
cptt05_(&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, "CPTSVX", (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 CDRVPT */
} /* cdrvpt_ */
/* 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 cgelsd_(integer *m, integer *n, integer *nrhs, complex * a, integer *lda, complex *b, integer *ldb, real *s, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer * iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer ie, il, mm;
real eps, anrm, bnrm;
integer itau, nlvl, iascl, ibscl;
real sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */
int cgebrd_(integer *, integer *, complex *, integer *, real *, real *, complex *, complex *, complex *, integer *, integer *), slabad_(real *, real *);
extern real clange_(char *, integer *, integer *, complex *, integer *, real *);
extern /* Subroutine */
int cgelqf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clalsd_( char *, integer *, integer *, integer *, real *, real *, complex * , integer *, real *, integer *, complex *, real *, integer *, integer *), clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
real bignum;
extern /* Subroutine */
int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), cunmbr_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), slaset_( char *, integer *, integer *, real *, real *, real *, integer *), cunmlq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer ldwork;
extern /* Subroutine */
int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer liwork, minwrk, maxwrk;
real smlnum;
integer lrwork;
logical lquery;
integer nrwork, smlsiz;
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--s;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
lquery = *lwork == -1;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
else if (*ldb < max(1,maxmn))
{
*info = -7;
}
/* 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.) */
if (*info == 0)
{
minwrk = 1;
maxwrk = 1;
liwork = 1;
lrwork = 1;
if (minmn > 0)
{
smlsiz = ilaenv_(&c__9, "CGELSD", " ", &c__0, &c__0, &c__0, &c__0);
mnthr = ilaenv_(&c__6, "CGELSD", " ", m, n, nrhs, &c_n1);
/* Computing MAX */
i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log( 2.f)) + 1;
nlvl = max(i__1,0);
liwork = minmn * 3 * nlvl + minmn * 11;
mm = *m;
if (*m >= *n && *m >= mnthr)
{
/* Path 1a - overdetermined, with many more rows than */
/* columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *nrhs * ilaenv_(&c__1, "CUNMQR", "LC", m, nrhs, n, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
}
if (*m >= *n)
{
/* Path 1 - overdetermined or exactly determined. */
/* Computing MAX */
/* Computing 2nd power */
i__3 = smlsiz + 1;
i__1 = i__3 * i__3;
i__2 = *n * (*nrhs + 1) + (*nrhs << 1); // , expr subst
lrwork = *n * 10 + (*n << 1) * smlsiz + (*n << 3) * nlvl + smlsiz * 3 * *nrhs + max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1, "CGEBRD", " ", &mm, n, &c_n1, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, "CUNMBR", "QLC", &mm, nrhs, n, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "CUNMBR", "PLN", n, nrhs, n, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*n << 1) + *n * *nrhs; // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = (*n << 1) + mm;
i__2 = (*n << 1) + *n * *nrhs; // , expr subst
minwrk = max(i__1,i__2);
}
if (*n > *m)
{
/* Computing MAX */
/* Computing 2nd power */
i__3 = smlsiz + 1;
i__1 = i__3 * i__3;
i__2 = *n * (*nrhs + 1) + (*nrhs << 1); // , expr subst
lrwork = *m * 10 + (*m << 1) * smlsiz + (*m << 3) * nlvl + smlsiz * 3 * *nrhs + max(i__1,i__2);
if (*n >= mnthr)
{
/* Path 2a - underdetermined, with many more columns */
/* than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, & c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + (*m << 2) + (*m << 1) * ilaenv_(&c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&c__1, "CUNMBR", "QLC", m, nrhs, m, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + (*m << 2) + (*m - 1) * ilaenv_(&c__1, "CUNMLQ", "LC", n, nrhs, m, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
if (*nrhs > 1)
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + *m + *m * *nrhs; // , expr subst
maxwrk = max(i__1,i__2);
}
else
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + (*m << 1); // , expr subst
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk;
i__2 = *m * *m + (*m << 2) + *m * *nrhs; // , expr subst
maxwrk = max(i__1,i__2);
/* XXX: Ensure the Path 2a case below is triggered. The workspace */
/* calculation should use queries for all routines eventually. */
/* Computing MAX */
/* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4);
i__3 = max(i__3,*nrhs);
i__4 = *n - *m * 3; // ; expr subst
i__1 = maxwrk;
i__2 = (*m << 2) + *m * *m + max(i__3,i__4) ; // , expr subst
maxwrk = max(i__1,i__2);
}
else
{
/* Path 2 - underdetermined. */
maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "CGEBRD", " ", m, n, &c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1, "CUNMBR", "QLC", m, nrhs, m, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*m << 1) + *m * ilaenv_(&c__1, "CUNMBR", "PLN", n, nrhs, m, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*m << 1) + *m * *nrhs; // , expr subst
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = (*m << 1) + *n;
i__2 = (*m << 1) + *m * *nrhs; // , expr subst
minwrk = max(i__1,i__2);
}
}
minwrk = min(minwrk,maxwrk);
work[1].r = (real) maxwrk;
work[1].i = 0.f; // , expr subst
iwork[1] = liwork;
rwork[1] = (real) lrwork;
if (*lwork < minwrk && ! lquery)
{
*info = -12;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGELSD", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0)
{
*rank = 0;
return 0;
}
/* Get machine parameters. */
eps = slamch_("P");
sfmin = slamch_("S");
smlnum = sfmin / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
iascl = 0;
if (anrm > 0.f && anrm < smlnum)
{
/* Scale matrix norm up to SMLNUM */
clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info);
iascl = 1;
}
else if (anrm > bignum)
{
/* Scale matrix norm down to BIGNUM. */
clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info);
iascl = 2;
}
else if (anrm == 0.f)
{
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
slaset_("F", &minmn, &c__1, &c_b80, &c_b80, &s[1], &c__1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum)
{
/* Scale matrix norm up to SMLNUM. */
clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info);
ibscl = 1;
}
else if (bnrm > bignum)
{
/* Scale matrix norm down to BIGNUM. */
clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info);
ibscl = 2;
}
/* If M < N make sure B(M+1:N,:) = 0 */
if (*m < *n)
{
i__1 = *n - *m;
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
}
/* Overdetermined case. */
if (*m >= *n)
{
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr)
{
/* Path 1a - overdetermined, with many more rows than columns */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R. */
/* (RWorkspace: need N) */
/* (CWorkspace: need N, prefer N*NB) */
i__1 = *lwork - nwork + 1;
cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info);
/* Multiply B by transpose(Q). */
/* (RWorkspace: need N) */
/* (CWorkspace: need NRHS, prefer NRHS*NB) */
i__1 = *lwork - nwork + 1;
cunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below R. */
if (*n > 1)
{
i__1 = *n - 1;
i__2 = *n - 1;
claset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
}
}
itauq = 1;
itaup = itauq + *n;
nwork = itaup + *n;
ie = 1;
nrwork = ie + *n;
/* Bidiagonalize R in A. */
/* (RWorkspace: need N) */
/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
cgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], & work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R. */
/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
cunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
clalsd_("U", &smlsiz, n, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info);
if (*info != 0)
{
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
cunmbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & b[b_offset], ldb, &work[nwork], &i__1, info);
}
else /* if(complicated condition) */
{
/* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2);
i__1 = max( i__1,*nrhs);
i__2 = *n - *m * 3; // ; expr subst
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2))
{
/* Path 2a - underdetermined, with many more columns than rows */
/* and sufficient workspace for an efficient algorithm. */
ldwork = *m;
/* Computing MAX */
/* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4);
i__3 = max(i__3,*nrhs);
i__4 = *n - *m * 3; // ; expr subst
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4);
i__2 = *m * *lda + *m + *m * *nrhs; // , expr subst
if (*lwork >= max(i__1,i__2))
{
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q. */
/* (CWorkspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
i__1 = *m - 1;
i__2 = *m - 1;
claset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwork], & ldwork);
itauq = il + ldwork * *m;
itaup = itauq + *m;
nwork = itaup + *m;
ie = 1;
nrwork = ie + *m;
/* Bidiagonalize L in WORK(IL). */
/* (RWorkspace: need M) */
/* (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
cgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L. */
/* (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
cunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[ itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
clalsd_("U", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info);
if (*info != 0)
{
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
cunmbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[ itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below first M rows of B. */
i__1 = *n - *m;
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
nwork = itau + *m;
/* Multiply transpose(Q) by B. */
/* (CWorkspace: need NRHS, prefer NRHS*NB) */
i__1 = *lwork - nwork + 1;
cunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ b_offset], ldb, &work[nwork], &i__1, info);
}
else
{
/* Path 2 - remaining underdetermined cases. */
itauq = 1;
itaup = itauq + *m;
nwork = itaup + *m;
ie = 1;
nrwork = ie + *m;
/* Bidiagonalize A. */
/* (RWorkspace: need M) */
/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors. */
/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
cunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq] , &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
clalsd_("L", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info);
if (*info != 0)
{
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
cunmbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup] , &b[b_offset], ldb, &work[nwork], &i__1, info);
}
}
/* Undo scaling. */
if (iascl == 1)
{
clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info);
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & minmn, info);
}
else if (iascl == 2)
{
clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info);
slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & minmn, info);
}
if (ibscl == 1)
{
clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info);
}
else if (ibscl == 2)
{
clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info);
}
L10:
work[1].r = (real) maxwrk;
work[1].i = 0.f; // , expr subst
iwork[1] = liwork;
rwork[1] = (real) lrwork;
return 0;
/* End of CGELSD */
}
/* Subroutine */ int cchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
*thresh, complex *a, integer *lda, real *bd, real *be, real *s1, real
*s2, complex *x, integer *ldx, complex *y, complex *z__, complex *q,
integer *ldq, complex *pt, integer *ldpt, complex *u, complex *vt,
complex *work, integer *lwork, real *rwork, integer *nout, integer *
info)
{
/* Initialized data */
static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
/* Format strings */
static char fmt_9998[] = "(\002 CCHKBD: \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_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
"=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double log(doublereal), sqrt(doublereal), exp(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static real cond;
static integer jcol;
static char path[3];
static integer mmax, nmax;
static real unfl, ovfl;
static char uplo[1];
static real temp1, temp2;
static integer i__, j, m, n;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *);
static logical badmm, badnn;
extern /* Subroutine */ int cbdt02_(integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
real *, real *), cbdt03_(char *, integer *, integer *, real *,
real *, complex *, integer *, real *, complex *, integer *,
complex *, real *);
static integer nfail, imode;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real dumma[1];
static integer iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
static real anorm;
static integer mnmin, mnmax, jsize, itype, jtype, iwork[1], ntest;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slahd2_(integer *, char *);
static integer log2ui;
static logical bidiag;
extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
integer *, real *, real *, complex *, complex *, complex *,
integer *, integer *), slabad_(real *, real *);
static integer mq;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int cbdsqr_(char *, integer *, integer *, integer
*, integer *, real *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *),
cungbr_(char *, integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
static real amninv;
extern /* Subroutine */ int ssvdch_(integer *, real *, real *, real *,
real *, integer *);
static integer minwrk;
static real rtunfl, rtovfl, ulpinv, result[14];
static integer mtypes;
static real ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 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_9998, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 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)]
/* -- 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
=======
CCHKBD checks the singular value decomposition (SVD) routines.
CGEBRD reduces a complex general m by n matrix A to real upper or
lower bidiagonal form by an orthogonal transformation: Q' * A * P = B
(or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n
and lower bidiagonal if m < n.
CUNGBR generates the orthogonal matrices Q and P' from CGEBRD.
Note that Q and P are not necessarily square.
CBDSQR computes the singular value decomposition of the bidiagonal
matrix B as B = U S V'. It is called three times to compute
1) B = U S1 V', where S1 is the diagonal matrix of singular
values and the columns of the matrices U and V are the left
and right singular vectors, respectively, of B.
2) Same as 1), but the singular values are stored in S2 and the
singular vectors are not computed.
3) A = (UQ) S (P'V'), the SVD of the original matrix A.
In addition, CBDSQR has an option to apply the left orthogonal matrix
U to a matrix X, useful in least squares applications.
For each pair of matrix dimensions (M,N) and each selected matrix
type, an M by N matrix A and an M by NRHS matrix X are generated.
The problem dimensions are as follows
A: M x N
Q: M x min(M,N) (but M x M if NRHS > 0)
P: min(M,N) x N
B: min(M,N) x min(M,N)
U, V: min(M,N) x min(M,N)
S1, S2 diagonal, order min(M,N)
X: M x NRHS
For each generated matrix, 14 tests are performed:
Test CGEBRD and CUNGBR
(1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
(2) | I - Q' Q | / ( M ulp )
(3) | I - PT PT' | / ( N ulp )
Test CBDSQR on bidiagonal matrix B
(4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
(5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
and Z = U' Y.
(6) | I - U' U | / ( min(M,N) ulp )
(7) | I - VT VT' | / ( min(M,N) ulp )
(8) S1 contains min(M,N) nonnegative values in decreasing order.
(Return 0 if true, 1/ULP if false.)
(9) 0 if the true singular values of B are within THRESH of
those in S1. 2*THRESH if they are not. (Tested using
SSVDCH)
(10) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
computing U and V.
Test CBDSQR on matrix A
(11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
(12) | X - (QU) Z | / ( |X| max(M,k) ulp )
(13) | I - (QU)'(QU) | / ( M ulp )
(14) | I - (VT PT) (PT'VT') | / ( N ulp )
The possible matrix types are
(1) The zero matrix.
(2) The identity matrix.
(3) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(4) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(6) Same as (3), but multiplied by SQRT( overflow threshold )
(7) Same as (3), but multiplied by SQRT( underflow threshold )
(8) A matrix of the form U D V, where U and V are orthogonal and
D has evenly spaced entries 1, ..., ULP with random signs
on the diagonal.
(9) A matrix of the form U D V, where U and V are orthogonal and
D has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal.
(10) A matrix of the form U D V, where U and V are orthogonal and
D has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal.
(11) Same as (8), but multiplied by SQRT( overflow threshold )
(12) Same as (8), but multiplied by SQRT( underflow threshold )
(13) Rectangular matrix with random entries chosen from (-1,1).
(14) Same as (13), but multiplied by SQRT( overflow threshold )
(15) Same as (13), but multiplied by SQRT( underflow threshold )
Special case:
(16) A bidiagonal matrix with random entries chosen from a
logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each
entry is e^x, where x is chosen uniformly on
[ 2 log(ulp), -2 log(ulp) ] .) For *this* type:
(a) CGEBRD is not called to reduce it to bidiagonal form.
(b) the bidiagonal is min(M,N) x min(M,N); if M<N, the
matrix will be lower bidiagonal, otherwise upper.
(c) only tests 5--8 and 14 are performed.
A subset of the full set of matrix types may be selected through
the logical array DOTYPE.
Arguments
==========
NSIZES (input) INTEGER
The number of values of M and N contained in the vectors
MVAL and NVAL. The matrix sizes are used in pairs (M,N).
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NVAL (input) INTEGER array, dimension (NM)
The values of the matrix column dimension N.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, CCHKBD
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.
NRHS (input) INTEGER
The number of columns in the "right-hand side" matrices X, Y,
and Z, used in testing CBDSQR. If NRHS = 0, then the
operations on the right-hand side will not be tested.
NRHS must be at least 0.
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 values of ISEED are changed on exit, and can be
used in the next call to CCHKBD to continue the same random
number sequence.
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. Note that the
expected value of the test ratios is O(1), so THRESH should
be a reasonably small multiple of 1, e.g., 10 or 100.
A (workspace) COMPLEX array, dimension (LDA,NMAX)
where NMAX is the maximum value of N in NVAL.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,MMAX),
where MMAX is the maximum value of M in MVAL.
BD (workspace) REAL array, dimension
(max(min(MVAL(j),NVAL(j))))
BE (workspace) REAL array, dimension
(max(min(MVAL(j),NVAL(j))))
S1 (workspace) REAL array, dimension
(max(min(MVAL(j),NVAL(j))))
S2 (workspace) REAL array, dimension
(max(min(MVAL(j),NVAL(j))))
X (workspace) COMPLEX array, dimension (LDX,NRHS)
LDX (input) INTEGER
The leading dimension of the arrays X, Y, and Z.
LDX >= max(1,MMAX).
Y (workspace) COMPLEX array, dimension (LDX,NRHS)
Z (workspace) COMPLEX array, dimension (LDX,NRHS)
Q (workspace) COMPLEX array, dimension (LDQ,MMAX)
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,MMAX).
PT (workspace) COMPLEX array, dimension (LDPT,NMAX)
LDPT (input) INTEGER
The leading dimension of the arrays PT, U, and V.
LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
U (workspace) COMPLEX array, dimension
(LDPT,max(min(MVAL(j),NVAL(j))))
V (workspace) COMPLEX array, dimension
(LDPT,max(min(MVAL(j),NVAL(j))))
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all
pairs (M,N)=(MM(j),NN(j))
RWORK (workspace) REAL array, dimension
(5*max(min(M,N)))
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
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
-6: NRHS < 0
-8: THRESH < 0
-11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
-17: LDB < 1 or LDB < MMAX.
-21: LDQ < 1 or LDQ < MMAX.
-23: LDP < 1 or LDP < MNMAX.
-27: LWORK too small.
If CLATMR, CLATMS, CGEBRD, CUNGBR, or CBDSQR,
returns an error code, the
absolute value of it is returned.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NTEST The number of tests performed, or which can
be performed so far, for the current matrix.
MMAX Largest value in NN.
NMAX Largest value in NN.
MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal
matrix.)
MNMAX The maximum value of MNMIN for j=1,...,NSIZES.
NFAIL The number of tests which have exceeded THRESH
COND, IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
RTOVFL, RTUNFL Square roots of the previous 2 values.
ULP, ULPINV Finest relative precision and its inverse.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
======================================================================
Parameter adjustments */
--mval;
--nval;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--bd;
--be;
--s1;
--s2;
z_dim1 = *ldx;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
y_dim1 = *ldx;
y_offset = 1 + y_dim1 * 1;
y -= y_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
vt_dim1 = *ldpt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldpt;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1 * 1;
pt -= pt_offset;
--work;
--rwork;
/* Function Body
Check for errors */
*info = 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 = mval[j];
mmax = max(i__2,i__3);
if (mval[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nval[j];
nmax = max(i__2,i__3);
if (nval[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX
Computing MIN */
i__4 = mval[j], i__5 = nval[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* Computing MAX
Computing MAX */
i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
i__6 = nval[j], i__7 = mval[j];
i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
min(i__6,i__7);
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 (*nrhs < 0) {
*info = -6;
} else if (*lda < mmax) {
*info = -11;
} else if (*ldx < mmax) {
*info = -17;
} else if (*ldq < mmax) {
*info = -21;
} else if (*ldpt < mnmax) {
*info = -23;
} else if (minwrk > *lwork) {
*info = -27;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CCHKBD", &i__1);
return 0;
}
/* Initialize constants */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
nfail = 0;
ntest = 0;
unfl = slamch_("Safe minimum");
ovfl = slamch_("Overflow");
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
log2ui = (integer) (log(ulpinv) / log(2.f));
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
infoc_1.infot = 0;
/* Loop over sizes, types */
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mval[jsize];
n = nval[jsize];
mnmin = min(m,n);
/* Computing MAX */
i__2 = max(m,n);
amninv = 1.f / max(i__2,1);
if (*nsizes != 1) {
mtypes = min(16,*ntypes);
} else {
mtypes = min(17,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.f;
/* L30: */
}
*(unsigned char *)uplo = ' ';
/* Compute "A"
Control parameters:
KMAGN KMODE KTYPE
=1 O(1) clustered 1 zero
=2 large clustered 2 identity
=3 small exponential (none)
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random symmetric, w/ eigenvalues
=6 nonsymmetric, w/ singular values
=7 random diagonal
=8 random symmetric
=9 random nonsymmetric
=10 random bidiagonal (log. distrib.) */
if (mtypes > 16) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
bidiag = FALSE_;
if (itype == 1) {
/* Zero matrix */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = mnmin;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = a_subscr(jcol, jcol);
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &rwork[1], &
imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &rwork[1], &
imode, &cond, &anorm, &m, &n, "N", &a[a_offset], lda,
&work[1], &iinfo);
} else if (itype == 6) {
/* Nonsymmetric, singular values specified */
clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &cond,
&anorm, &m, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N",
iwork, &c__0, &c__0, &c_b47, &anorm, "NO", &a[
a_offset], lda, iwork, &iinfo);
} else if (itype == 8) {
/* Symmetric, random entries */
clatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
&c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N",
iwork, &m, &n, &c_b47, &anorm, "NO", &a[a_offset],
lda, iwork, &iinfo);
} else if (itype == 9) {
/* Nonsymmetric, random entries */
clatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
&c_b2, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
work[m + mnmin + 1], &c__1, &c_b37, "N", iwork, &m, &
n, &c_b47, &anorm, "NO", &a[a_offset], lda, iwork, &
iinfo);
} else if (itype == 10) {
/* Bidiagonal, random entries */
temp1 = log(ulp) * -2.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
bd[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
if (j < mnmin) {
be[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
}
/* L90: */
}
iinfo = 0;
bidiag = TRUE_;
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
} else {
iinfo = 1;
}
if (iinfo == 0) {
/* Generate Right-Hand Side */
if (bidiag) {
clatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
c__6, &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &
c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
c_b37, "N", iwork, &mnmin, nrhs, &c_b47, &c_b37,
"NO", &y[y_offset], ldx, iwork, &iinfo);
} else {
clatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b37, &c_b2, "T", "N", &work[m + 1], &c__1, &
c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N",
iwork, &m, nrhs, &c_b47, &c_b37, "NO", &x[
x_offset], ldx, iwork, &iinfo);
}
}
/* Error Exit */
if (iinfo != 0) {
io___40.ciunit = *nout;
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 *)&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;
}
L100:
/* Call CGEBRD and CUNGBR to compute B, Q, and P, do tests. */
if (! bidiag) {
/* Compute transformations to reduce A to bidiagonal form:
B := Q' * A * P. */
clacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
i__3 = *lwork - (mnmin << 1);
cgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
iinfo);
/* Check error code from CGEBRD. */
if (iinfo != 0) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "CGEBRD", (ftnlen)6);
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;
}
clacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
/* Generate Q */
mq = m;
if (*nrhs <= 0) {
mq = mnmin;
}
i__3 = *lwork - (mnmin << 1);
cungbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "CUNGBR(Q)", (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;
}
/* Generate P' */
i__3 = *lwork - (mnmin << 1);
cungbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from CUNGBR. */
if (iinfo != 0) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "CUNGBR(P)", (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;
}
/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
cgemm_("Conjugate transpose", "No transpose", &m, nrhs, &m, &
c_b2, &q[q_offset], ldq, &x[x_offset], ldx, &c_b1, &y[
y_offset], ldx);
/* Test 1: Check the decomposition A := Q * B * PT
2: Check the orthogonality of Q
3: Check the orthogonality of PT */
cbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], &rwork[
1], result);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[1]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[2]);
}
/* Use CBDSQR to form the SVD of the bidiagonal matrix B:
B := U * S1 * VT, and compute Z = U' * Y. */
scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
clacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &u[u_offset], ldpt);
claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &vt[vt_offset],
ldpt);
cbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &rwork[1], &
vt[vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset],
ldx, &rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "CBDSQR(vects)", (ftnlen)13);
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);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L150;
}
}
/* Use CBDSQR to compute only the singular values of the
bidiagonal matrix B; U, VT, and Z should not be modified. */
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &rwork[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&rwork[mnmin + 1], &iinfo);
/* Check error code from CBDSQR. */
if (iinfo != 0) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "CBDSQR(values)", (ftnlen)14);
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);
if (iinfo < 0) {
return 0;
} else {
result[8] = ulpinv;
goto L150;
}
}
/* Test 4: Check the decomposition B := U * S1 * VT
5: Check the computation Z := U' * Y
6: Check the orthogonality of U
7: Check the orthogonality of VT */
cbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
cbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
u_offset], ldpt, &work[1], &rwork[1], &result[4]);
cunt01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &rwork[1], &result[5]);
cunt01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[6]);
/* Test 8: Check that the singular values are sorted in
non-increasing order and are non-negative */
result[7] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[7] = ulpinv;
}
if (s1[i__] < 0.f) {
result[7] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.f) {
result[7] = ulpinv;
}
}
/* Test 9: Compare CBDSQR with and without singular vectors */
temp2 = 0.f;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX
Computing MAX */
r__6 = (r__1 = s1[j], dabs(r__1)), r__7 = (r__2 = s2[j], dabs(
r__2));
r__4 = sqrt(unfl) * dmax(s1[1],1.f), r__5 = ulp * dmax(r__6,
r__7);
temp1 = (r__3 = s1[j] - s2[j], dabs(r__3)) / dmax(r__4,r__5);
temp2 = dmax(temp1,temp2);
/* L120: */
}
result[8] = temp2;
/* Test 10: Sturm sequence test of singular values
Go up by factors of two until it succeeds */
temp1 = *thresh * (.5f - ulp);
i__3 = log2ui;
for (j = 0; j <= i__3; ++j) {
ssvdch_(&mnmin, &bd[1], &be[1], &s1[1], &temp1, &iinfo);
if (iinfo == 0) {
goto L140;
}
temp1 *= 2.f;
/* L130: */
}
L140:
result[9] = temp1;
/* Use CBDSQR to form the decomposition A := (QU) S (VT PT)
from the bidiagonal form A := Q B PT. */
if (! bidiag) {
scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
}
cbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &rwork[1], &pt[
pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
ldx, &rwork[mnmin + 1], &iinfo);
/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
12: Check the computation Z := U' * Q' * X
13: Check the orthogonality of Q*U
14: Check the orthogonality of VT*PT */
cbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &rwork[
1], &result[10]);
cbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
q_offset], ldq, &work[1], &rwork[1], &result[11]);
cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &rwork[1], &result[12]);
cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &rwork[1], &result[13]);
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= *thresh) {
if (nfail == 0) {
slahd2_(nout, path);
}
io___50.ciunit = *nout;
s_wsfe(&io___50);
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))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
/* L160: */
}
if (! bidiag) {
ntest += 14;
} else {
ntest += 5;
}
L170:
;
}
/* L180: */
}
/* Summary */
alasum_(path, nout, &nfail, &ntest, &c__0);
return 0;
/* End of CCHKBD */
} /* cchkbd_ */
/* Subroutine */ int claqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
complex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_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;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
complex s;
integer jw;
real foo;
integer kln;
complex tau;
integer knt;
real ulp;
integer lwk1, lwk2;
complex beta;
integer kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer
*, complex *, integer *);
integer infqr, kwtop;
extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, complex *, integer *, integer *), clacpy_(char *,
integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex
*, complex *, integer *);
real safmin, safmax;
extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, integer *, integer *),
cunmhr_(char *, char *, integer *, integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, complex
*, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* -- April 2009 -- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* This subroutine is identical to CLAQR3 except that it avoids */
/* recursion by calling CLAHQR instead of CLAQR4. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an unitary similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an unitary similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the unitary matrix Z is updated so */
/* so that the unitary Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the unitary matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by a unitary */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the unitary */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SH (output) COMPLEX array, dimension KBOT */
/* On output, approximate eigenvalues that may */
/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
/* through SR(KBOT-ND). Converged eigenvalues are */
/* stored in SH(KBOT-ND+1) through SH(KBOT). */
/* V (workspace) COMPLEX array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) COMPLEX array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) COMPLEX array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) COMPLEX array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; CLAQR2 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to CGEHRD ==== */
i__1 = jw - 1;
cgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to CUNMHR ==== */
i__1 = jw - 1;
cunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1.f, work[1].i = 0.f;
if (*ktop > *kbot) {
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s.r = 0.f, s.i = 0.f;
} else {
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r, s.i = h__[i__1].i;
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
r__5 = smlnum, r__6 = ulp * ((r__1 = h__[i__1].r, dabs(r__1)) + (r__2
= r_imag(&h__[kwtop + kwtop * h_dim1]), dabs(r__2)));
if ((r__3 = s.r, dabs(r__3)) + (r__4 = r_imag(&s), dabs(r__4)) <=
dmax(r__5,r__6)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
}
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
clacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
ccopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
claset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
clahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop],
&c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1; knt <= i__1; ++knt) {
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*ns + *ns *
t_dim1]), dabs(r__2));
if (foo == 0.f) {
foo = (r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
r__5 = smlnum, r__6 = ulp * foo;
if (((r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2))) * ((
r__3 = v[i__2].r, dabs(r__3)) + (r__4 = r_imag(&v[*ns *
v_dim1 + 1]), dabs(r__4))) <= dmax(r__5,r__6)) {
/* ==== One more converged eigenvalue ==== */
--(*ns);
} else {
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (CTREXC can not fail in this case.) ==== */
ifst = *ns;
ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s.r = 0.f, s.i = 0.f;
}
if (*ns < jw) {
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
ifst = i__;
i__2 = *ns;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[j + j *
t_dim1]), dabs(r__2)) > (r__3 = t[i__4].r, dabs(r__3)
) + (r__4 = r_imag(&t[ifst + ifst * t_dim1]), dabs(
r__4))) {
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst) {
ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
/* L40: */
}
if (*ns < jw || s.r == 0.f && s.i == 0.f) {
if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
/* ==== Reflect spike back into lower triangle ==== */
ccopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
r_cnjg(&q__1, &work[i__]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
beta.r = work[1].r, beta.i = work[1].i;
clarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1.f, work[1].i = 0.f;
i__1 = jw - 2;
i__2 = jw - 2;
claset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
r_cnjg(&q__1, &tau);
clarf_("L", ns, &jw, &work[1], &c__1, &q__1, &t[t_offset], ldt, &
work[jw + 1]);
clarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
clarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
cgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
r_cnjg(&q__2, &v[v_dim1 + 1]);
q__1.r = s.r * q__2.r - s.i * q__2.i, q__1.i = s.r * q__2.i + s.i
* q__2.r;
h__[i__1].r = q__1.r, h__[i__1].i = q__1.i;
}
clacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
ccopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
i__1 = *lwork - jw;
cunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
ldwv);
clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
cgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
ldt);
clacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
, ldwv);
clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
/* ==== End of CLAQR2 ==== */
return 0;
} /* claqr2_ */
/* Subroutine */ int cgelsy_(integer *m, integer *n, integer *nrhs, complex *
a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
integer *rank, complex *work, integer *lwork, real *rwork, integer *
info)
{
/* -- LAPACK driver 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
=======
CGELSY computes the minimum-norm solution to a complex linear least
squares problem:
minimize || A * X - B ||
using a complete orthogonal factorization of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution
matrix X.
The routine first computes a QR factorization with column pivoting:
A * P = Q * [ R11 R12 ]
[ 0 R22 ]
with R11 defined as the largest leading submatrix whose estimated
condition number is less than 1/RCOND. The order of R11, RANK,
is the effective rank of A.
Then, R22 is considered to be negligible, and R12 is annihilated
by unitary transformations from the right, arriving at the
complete orthogonal factorization:
A * P = Q * [ T11 0 ] * Z
[ 0 0 ]
The minimum-norm solution is then
X = P * Z' [ inv(T11)*Q1'*B ]
[ 0 ]
where Q1 consists of the first RANK columns of Q.
This routine is basically identical to the original xGELSX except
three differences:
o The permutation of matrix B (the right hand side) is faster and
more simple.
o The call to the subroutine xGEQPF has been substituted by the
the call to the subroutine xGEQP3. This subroutine is a Blas-3
version of the QR factorization with column pivoting.
o Matrix B (the right hand side) is updated with Blas-3.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of
columns of matrices B and X. NRHS >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A has been overwritten by details of its
complete orthogonal factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M,N).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of AP, otherwise column i is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
RCOND (input) REAL
RCOND is used to determine the effective rank of A, which
is defined as the order of the largest leading triangular
submatrix R11 in the QR factorization with pivoting of A,
whose estimated condition number < 1/RCOND.
RANK (output) INTEGER
The effective rank of A, i.e., the order of the submatrix
R11. This is the same as the order of the submatrix T11
in the complete orthogonal factorization of A.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
The unblocked strategy requires that:
LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
where MN = min(M,N).
The block algorithm requires that:
LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
where NB is an upper bound on the blocksize returned
by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,
and CUNMRZ.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) REAL array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
Based on contributions by
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__0 = 0;
static integer c__2 = 2;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
static real anrm, bnrm, smin, smax;
static integer i__, j, iascl, ibscl;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer ismin, ismax;
static complex c1, c2;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), claic1_(integer *,
integer *, complex *, real *, complex *, complex *, real *,
complex *, complex *);
static real wsize;
static complex s1, s2;
extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
integer *, integer *, complex *, complex *, integer *, real *,
integer *);
static integer nb;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static integer mn;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static real sminpr, smaxpr, smlnum;
extern /* Subroutine */ int cunmrz_(char *, char *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
extern /* Subroutine */ int ctzrzf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--jpvt;
--work;
--rwork;
/* Function Body */
mn = min(*m,*n);
ismin = mn + 1;
ismax = (mn << 1) + 1;
/* Test the input arguments. */
*info = 0;
nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen)
1);
nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen)
1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
/* Computing MAX */
i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(i__1,i__2),
i__2 = (mn << 1) + nb * *nrhs;
lwkopt = max(i__1,i__2);
q__1.r = (real) lwkopt, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn +
*nrhs;
if (*lwork < mn + max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGELSY", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
smlnum = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
*rank = 0;
goto L70;
}
bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* Compute QR factorization with column pivoting of A:
A * P = Q * R */
i__1 = *lwork - mn;
cgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
&rwork[1], info);
i__1 = mn + 1;
wsize = mn + work[i__1].r;
/* complex workspace: MN+NB*(N+1). real workspace 2*N.
Details of Householder rotations stored in WORK(1:MN).
Determine RANK using incremental condition estimation */
i__1 = ismin;
work[i__1].r = 1.f, work[i__1].i = 0.f;
i__1 = ismax;
work[i__1].r = 1.f, work[i__1].i = 0.f;
smax = c_abs(&a_ref(1, 1));
smin = smax;
if (c_abs(&a_ref(1, 1)) == 0.f) {
*rank = 0;
i__1 = max(*m,*n);
claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
goto L70;
} else {
*rank = 1;
}
L10:
if (*rank < mn) {
i__ = *rank + 1;
claic1_(&c__2, rank, &work[ismin], &smin, &a_ref(1, i__), &a_ref(i__,
i__), &sminpr, &s1, &c1);
claic1_(&c__1, rank, &work[ismax], &smax, &a_ref(1, i__), &a_ref(i__,
i__), &smaxpr, &s2, &c2);
if (smaxpr * *rcond <= sminpr) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ismin + i__ - 1;
i__3 = ismin + i__ - 1;
q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i =
s1.r * work[i__3].i + s1.i * work[i__3].r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = ismax + i__ - 1;
i__3 = ismax + i__ - 1;
q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i =
s2.r * work[i__3].i + s2.i * work[i__3].r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L20: */
}
i__1 = ismin + *rank;
work[i__1].r = c1.r, work[i__1].i = c1.i;
i__1 = ismax + *rank;
work[i__1].r = c2.r, work[i__1].i = c2.i;
smin = sminpr;
smax = smaxpr;
++(*rank);
goto L10;
}
}
/* complex workspace: 3*MN.
Logically partition R = [ R11 R12 ]
[ 0 R22 ]
where R11 = R(1:RANK,1:RANK)
[R11,R12] = [ T11, 0 ] * Y */
if (*rank < *n) {
i__1 = *lwork - (mn << 1);
ctzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
1], &i__1, info);
}
/* complex workspace: 2*MN.
Details of Householder rotations stored in WORK(MN+1:2*MN)
B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - (mn << 1);
cunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
/* Computing MAX */
i__1 = (mn << 1) + 1;
r__1 = wsize, r__2 = (mn << 1) + work[i__1].r;
wsize = dmax(r__1,r__2);
/* complex workspace: 2*MN+NB*NRHS.
B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
a_offset], lda, &b[b_offset], ldb);
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
if (*rank < *n) {
i__1 = *n - *rank;
i__2 = *lwork - (mn << 1);
cunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[
a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn <<
1) + 1], &i__2, info);
}
/* complex workspace: 2*MN+NRHS.
B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = jpvt[i__];
i__4 = b_subscr(i__, j);
work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i;
/* L50: */
}
ccopy_(n, &work[1], &c__1, &b_ref(1, j), &c__1);
/* L60: */
}
/* complex workspace: N.
Undo scaling */
if (iascl == 1) {
clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
lda, info);
} else if (iascl == 2) {
clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
lda, info);
}
if (ibscl == 1) {
clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L70:
q__1.r = (real) lwkopt, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CGELSY */
} /* cgelsy_ */
/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *
beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr,
complex *work, integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2, i__3;
/* Local variables */
integer nb, nb1, nb2, nb3, ihi, ilo;
real eps, anrm, bnrm;
integer itau, lopt;
extern logical lsame_(char *, char *);
integer ileft, iinfo, icols;
logical ilvsl;
integer iwork;
logical ilvsr;
integer irows;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, 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 *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *);
integer ijobvl, iright, ijobvr;
real anrmto;
integer lwkmin;
real bnrmto;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
cunmqr_(char *, char *, integer *, integer *, integer *, complex
*, integer *, complex *, complex *, integer *, complex *, integer
*, integer *);
real smlnum;
integer irwork, lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine CGGES. */
/* CGEGS computes the eigenvalues, Schur form, and, optionally, the */
/* left and or/right Schur vectors of a complex matrix pair (A,B). */
/* Given two square matrices A and B, the generalized Schur */
/* factorization has the form */
/* A = Q*S*Z**H, B = Q*T*Z**H */
/* where Q and Z are unitary matrices and S and T are upper triangular. */
/* The columns of Q are the left Schur vectors */
/* and the columns of Z are the right Schur vectors. */
/* If only the eigenvalues of (A,B) are needed, the driver routine */
/* CGEGV should be used instead. See CGEGV for a description of the */
/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
/* (GNEP). */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors (returned in VSL). */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors (returned in VSR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* On exit, the upper triangular matrix S from the generalized */
/* Schur factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* On exit, the upper triangular matrix T from the generalized */
/* Schur factorization. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur */
/* form of A. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The non-negative real scalars beta that define the */
/* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element */
/* of the triangular factor T. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* VSL (output) COMPLEX array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) COMPLEX array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: */
/* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; */
/* the optimal LWORK is N*(NB+1). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* =1,...,N: */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHA(j) and BETA(j) should be correct for */
/* j=INFO+1,...,N. */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from CGGBAL */
/* =N+2: error return from CGEQRF */
/* =N+3: error return from CUNMQR */
/* =N+4: error return from CUNGQR */
/* =N+5: error return from CGGHRD */
/* =N+6: error return from CHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from CGGBAK (computing VSL) */
/* =N+8: error return from CGGBAK (computing VSR) */
/* =N+9: error return from CLASCL (various places) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 1;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1].r = (real) lwkopt, work[1].i = 0.f;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -11;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -13;
} else if (*lwork < lwkmin && ! lquery) {
*info = -15;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
lopt = *n * (nb + 1);
work[1].r = (real) lopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEGS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("E") * slamch_("B");
safmin = slamch_("S");
smlnum = *n * safmin / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
ileft = 1;
iright = *n + 1;
irwork = iright + *n;
iwork = 1;
cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
ileft], &rwork[iright], &rwork[irwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ 1 + ilo * vsl_dim1], ldvsl);
i__1 = *lwork + 1 - iwork;
cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
iwork = itau;
i__1 = *lwork + 1 - iwork;
chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &rwork[irwork], &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsl[vsl_offset], ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
clascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
clascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
clascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
clascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CGEGS */
} /* cgegs_ */
/* Subroutine */ int chpt01_(char *uplo, integer *n, complex *a, complex *
afac, integer *ipiv, complex *c__, integer *ldc, real *rwork, real *
resid)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, jc;
real eps;
integer info;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPT01 reconstructs a Hermitian indefinite packed matrix A from its */
/* block L*D*L' or U*D*U' factorization and computes the residual */
/* norm( C - A ) / ( N * norm(A) * EPS ), */
/* where C is the reconstructed matrix, EPS is the machine epsilon, */
/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
/* of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The factored form of the matrix A, stored as a packed */
/* triangular matrix. AFAC contains the block diagonal matrix D */
/* and the multipliers used to obtain the factor L or U from the */
/* block L*D*L' or U*D*U' factorization as computed by CHPTRF. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from CHPTRF. */
/* C (workspace) COMPLEX array, dimension (LDC,N) */
/* LDC (integer) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--afac;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Determine EPS and the norm of A. */
eps = slamch_("Epsilon");
anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
jc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[jc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
jc = jc + j + 1;
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[jc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
jc = jc + *n - j + 1;
/* L20: */
}
}
/* Initialize C to the identity matrix. */
claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call CLAVHP to form the product D * U' (or D * L' ). */
clavhp_(uplo, "Conjugate", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Call CLAVHP again to multiply by U ( or L ). */
clavhp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__;
q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L30: */
}
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc + j;
r__1 = a[i__4].r;
q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
jc += j;
/* L40: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc;
r__1 = a[i__4].r;
q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__ - j;
q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L50: */
}
jc = jc + *n - j + 1;
/* L60: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = clanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / (real) (*n) / anorm / eps;
}
return 0;
/* End of CHPT01 */
} /* chpt01_ */
/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *
e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c,
integer *ldc, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGBBRD reduces a complex general m-by-n band matrix A to real upper
bidiagonal form B by a unitary transformation: Q' * A * P = B.
The routine computes B, and optionally forms Q or P', or computes
Q'*C for a given matrix C.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether or not the matrices Q and P' are to be
formed.
= 'N': do not form Q or P';
= 'Q': form Q only;
= 'P': form P' only;
= 'B': form both.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
KL (input) INTEGER
The number of subdiagonals of the matrix A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals of the matrix A. KU >= 0.
AB (input/output) COMPLEX array, dimension (LDAB,N)
On entry, the m-by-n band matrix A, stored in rows 1 to
KL+KU+1. The j-th column of A is stored in the j-th column of
the array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
On exit, A is overwritten by values generated during the
reduction.
LDAB (input) INTEGER
The leading dimension of the array A. LDAB >= KL+KU+1.
D (output) REAL array, dimension (min(M,N))
The diagonal elements of the bidiagonal matrix B.
E (output) REAL array, dimension (min(M,N)-1)
The superdiagonal elements of the bidiagonal matrix B.
Q (output) COMPLEX array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
If VECT = 'N' or 'P', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
PT (output) COMPLEX array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
If VECT = 'N' or 'Q', the array PT is not referenced.
LDPT (input) INTEGER
The leading dimension of the array PT.
LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
C (input/output) COMPLEX array, dimension (LDC,NCC)
On entry, an m-by-ncc matrix C.
On exit, C is overwritten by Q'*C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
WORK (workspace) COMPLEX array, dimension (max(M,N))
RWORK (workspace) REAL array, dimension (max(M,N))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
static integer inca;
static real abst;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
static integer i, j, l;
static complex t;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static complex ra;
static real rc;
static integer kk;
static complex rb;
static integer ml, nr, mu;
static complex rs;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
static integer kb1, ml0;
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define PT(I,J) pt[(I)-1 + ((J)-1)* ( *ldpt)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &Q(1,1), ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &PT(1,1), ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = min(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
first to lower bidiagonal form and then transform to upper
bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied
in
vector operations of length NR over the index set J1:J2:KLU1
.
The complex sines of the plane rotations are stored in WORK,
and the real cosines in RWORK.
Computing MIN */
i__1 = *m - 1;
klm = min(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = min(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
/* Reduce i-th column and i-th row of matrix to bidiagon
al form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= kb; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero
elements
which have been created below the band */
if (nr > 0) {
clargv_(&nr, &AB(klu1,j1-klm-1), &inca,
&WORK(j1), &kb1, &RWORK(j1), &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(klu1-l,j1-klm+l-1), &inca, &AB(klu1-l+1,j1-klm+l-1), &inca, &RWORK(j1), &WORK(
j1), &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i + 1) {
/* generate plane rotation to annih
ilate a(i+ml-1,i)
within the band, and apply rotat
ion from the left */
clartg_(&AB(*ku+ml-1,i), &AB(*ku+ml,i), &RWORK(i + ml - 1), &WORK(i +
ml - 1), &ra);
i__3 = *ku + ml - 1 + i * ab_dim1;
AB(*ku+ml-1,i).r = ra.r, AB(*ku+ml-1,i).i = ra.i;
if (i < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i;
i__3 = min(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &AB(*ku+ml-2,i+1)
, &i__6, &AB(*ku+ml-1,i+1), &i__7, &RWORK(i + ml - 1), &
WORK(i + ml - 1));
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations i
n Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j));
crot_(m, &Q(1,j-1), &c__1, &Q(1,j), &c__1, &RWORK(j), &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
crot_(ncc, &C(j-1,1), ldc, &C(j,1),
ldc, &RWORK(j), &WORK(j));
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j-1,j+ku) abov
e the band
and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = WORK(j).r * AB(1,j+kun).r - WORK(j).i * AB(1,j+kun).i, q__1.i = WORK(j).r * AB(1,j+kun).i +
WORK(j).i * AB(1,j+kun).r;
WORK(j+kun).r = q__1.r, WORK(j+kun).i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = RWORK(j) * AB(1,j+kun).r, q__1.i = RWORK(j) *
AB(1,j+kun).i;
AB(1,j+kun).r = q__1.r, AB(1,j+kun).i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero
elements
which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &AB(1,j1+kun-1), &inca, &
WORK(j1 + kun), &kb1, &RWORK(j1 + kun), &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= kb; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &AB(l+1,j1+kun-1), &
inca, &AB(l,j1+kun), &inca, &
RWORK(j1 + kun), &WORK(j1 + kun), &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i + 1) {
/* generate plane rotation to annih
ilate a(i,i+mu-1)
within the band, and apply rotat
ion from the right */
clartg_(&AB(*ku-mu+3,i+mu-2), &
AB(*ku-mu+2,i+mu-1), &
RWORK(i + mu - 1), &WORK(i + mu - 1), &ra);
i__4 = *ku - mu + 3 + (i + mu - 2) * ab_dim1;
AB(*ku-mu+3,i+mu-2).r = ra.r, AB(*ku-mu+3,i+mu-2).i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i;
i__4 = min(i__3,i__5);
crot_(&i__4, &AB(*ku-mu+4,i+mu-2), &c__1, &AB(*ku-mu+3,i+mu-1), &c__1, &RWORK(i + mu - 1), &
WORK(i + mu - 1));
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations i
n P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1)
{
r_cnjg(&q__1, &WORK(j + kun));
crot_(n, &PT(j+kun-1,1), ldpt, &PT(j+kun,1), ldpt, &RWORK(j + kun), &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of
the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; kb1 < 0 ? j >= j2 : j <= j2; j += kb1) {
/* create nonzero element a(j+kl+ku,j+ku-1
) below the
band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = WORK(j+kun).r * AB(klu1,j+kun).r - WORK(j+kun).i * AB(klu1,j+kun).i, q__1.i = WORK(j+kun).r * AB(klu1,j+kun).i +
WORK(j+kun).i * AB(klu1,j+kun).r;
WORK(j+kb).r = q__1.r, WORK(j+kb).i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = RWORK(j+kun) * AB(klu1,j+kun).r, q__1.i = RWORK(j+kun) *
AB(klu1,j+kun).i;
AB(klu1,j+kun).r = q__1.r, AB(klu1,j+kun).i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by apply
ing
plane rotations from the left, overwriting superdiagonal
elements on subdiagonal elements
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i = 1; i <= min(*m-1,*n); ++i) {
clartg_(&AB(1,i), &AB(2,i), &rc, &rs, &ra)
;
i__2 = i * ab_dim1 + 1;
AB(1,i).r = ra.r, AB(1,i).i = ra.i;
if (i < *n) {
i__2 = i * ab_dim1 + 2;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rs.r * AB(1,i+1).r - rs.i * AB(1,i+1).i, q__1.i = rs.r
* AB(1,i+1).i + rs.i * AB(1,i+1).r;
AB(2,i).r = q__1.r, AB(2,i).i = q__1.i;
i__2 = (i + 1) * ab_dim1 + 1;
i__4 = (i + 1) * ab_dim1 + 1;
q__1.r = rc * AB(1,i+1).r, q__1.i = rc * AB(1,i+1).i;
AB(1,i+1).r = q__1.r, AB(1,i+1).i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &Q(1,i), &c__1, &Q(1,i+1),
&c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &C(i,1), ldc, &C(i+1,1), ldc, &rc,
&rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is
diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from
the
right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = AB(*ku,*m+1).r, rb.i = AB(*ku,*m+1).i;
for (i = *m; i >= 1; --i) {
clartg_(&AB(*ku+1,i), &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i * ab_dim1;
AB(*ku+1,i).r = ra.r, AB(*ku+1,i).i = ra.i;
if (i > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)
q__3.i;
i__1 = *ku + i * ab_dim1;
q__1.r = q__2.r * AB(*ku,i).r - q__2.i * AB(*ku,i).i,
q__1.i = q__2.r * AB(*ku,i).i + q__2.i * AB(*ku,i)
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i * ab_dim1;
i__2 = *ku + i * ab_dim1;
q__1.r = rc * AB(*ku,i).r, q__1.i = rc * AB(*ku,i).i;
AB(*ku,i).r = q__1.r, AB(*ku,i).i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &PT(i,1), ldpt, &PT(*m+1,1),
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements real, storing them in D
and E */
i__1 = *ku + 1 + ab_dim1;
t.r = AB(*ku+1,1).r, t.i = AB(*ku+1,1).i;
i__1 = minmn;
for (i = 1; i <= minmn; ++i) {
abst = c_abs(&t);
D(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &Q(1,i), &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &C(i,1), ldc);
}
if (i < minmn) {
if (*ku == 0 && *kl == 0) {
E(i) = 0.f;
i__2 = (i + 1) * ab_dim1 + 1;
t.r = AB(1,i+1).r, t.i = AB(1,i+1).i;
} else {
if (*ku == 0) {
i__2 = i * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = AB(2,i).r * q__2.r - AB(2,i).i * q__2.i,
q__1.i = AB(2,i).r * q__2.i + AB(2,i).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku,i+1).r * q__2.r - AB(*ku,i+1).i * q__2.i,
q__1.i = AB(*ku,i+1).r * q__2.i + AB(*ku,i+1).i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
E(i) = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &PT(i+1,1), ldpt);
}
i__2 = *ku + 1 + (i + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = AB(*ku+1,i+1).r * q__2.r - AB(*ku+1,i+1).i * q__2.i, q__1.i =
AB(*ku+1,i+1).r * q__2.i + AB(*ku+1,i+1).i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
static integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
integer *, complex *, 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 *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_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 af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_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
=======
CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n
matrix A, and partially tests CUNGQL which forms the m-by-m
orthogonal matrix Q.
CQLT01 compares L with Q'*A, and checks that Q is orthogonal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the QL factorization of A, as returned by CGEQLF.
See CGEQLF for further details.
Q (output) COMPLEX array, dimension (LDA,M)
The m-by-m orthogonal matrix Q.
L (workspace) COMPLEX array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R.
LDA >= max(M,N).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by CGEQLF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6);
cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n
+ 1), lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, &
q_ref(*m - *n + 1, *m - *n + 2), lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, &
q_ref(1, 2), lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
clacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - *
n + 1, 1), lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
clacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n
- *m + 1), lda);
}
}
/* Compute L - Q'*A */
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT01 */
} /* cqlt01_ */
/* Subroutine */ int cget36_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static complex diag[10];
static integer ifst, ilst;
static complex work[200];
static integer info1, info2, i__, j, n;
static complex q[100] /* was [10][10] */;
extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *);
static complex ctemp;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static real rwork[10];
static complex t1[100] /* was [10][10] */, t2[100] /* was [10][
10] */;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), ctrexc_(char *, integer *, complex *, integer *, complex
*, integer *, integer *, integer *, integer *);
static real result[2], eps, res;
static complex tmp[100] /* was [10][10] */;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
#define q_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define t1_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t1_ref(a_1,a_2) t1[t1_subscr(a_1,a_2)]
#define t2_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define t2_ref(a_1,a_2) t2[t2_subscr(a_1,a_2)]
#define tmp_subscr(a_1,a_2) (a_2)*10 + a_1 - 11
#define tmp_ref(a_1,a_2) tmp[tmp_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
=======
CGET36 tests CTREXC, a routine for reordering diagonal entries of a
matrix in complex Schur form. Thus, CLAEXC computes a unitary matrix
Q such that
Q' * T1 * Q = T2
and where one of the diagonal blocks of T1 (the one at row IFST) has
been moved to position ILST.
The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
is in Schur form, and that the final position of the IFST block is
ILST.
The test matrices are read from a file with logical unit number NIN.
Arguments
==========
RMAX (output) REAL
Value of the largest test ratio.
LMAX (output) INTEGER
Example number where largest test ratio achieved.
NINFO (output) INTEGER
Number of examples where INFO is nonzero.
KNT (output) INTEGER
Total number of examples tested.
NIN (input) INTEGER
Input logical unit number.
===================================================================== */
eps = slamch_("P");
*rmax = 0.f;
*lmax = 0;
*knt = 0;
*ninfo = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&tmp_ref(i__, j), (ftnlen)sizeof(
complex));
}
e_rsle();
/* L20: */
}
clacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
clacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
res = 0.f;
/* Test without accumulating Q */
claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ctrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = q_subscr(i__, j);
if (i__ == j && (q[i__3].r != 1.f || q[i__3].i != 0.f)) {
res += 1.f / eps;
}
i__3 = q_subscr(i__, j);
if (i__ != j && (q[i__3].r != 0.f || q[i__3].i != 0.f)) {
res += 1.f / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
ctrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = t1_subscr(i__, j);
i__4 = t2_subscr(i__, j);
if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
res += 1.f / eps;
}
/* L50: */
}
/* L60: */
}
if (info1 != 0 || info2 != 0) {
++(*ninfo);
}
if (info1 != info2) {
res += 1.f / eps;
}
/* Test for successful reordering of T2 */
ccopy_(&n, tmp, &c__11, diag, &c__1);
if (ifst < ilst) {
i__1 = ilst;
for (i__ = ifst + 1; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__ - 1;
i__3 = i__ - 2;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 2;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L70: */
}
} else if (ifst > ilst) {
i__1 = ilst;
for (i__ = ifst - 1; i__ >= i__1; --i__) {
i__2 = i__;
ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
i__2 = i__;
i__3 = i__ - 1;
diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
i__2 = i__ - 1;
diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
/* L80: */
}
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = t2_subscr(i__, i__);
i__3 = i__ - 1;
if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
res += 1.f / eps;
}
/* L90: */
}
/* Test for small residual, and orthogonality of Q */
chst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
rwork, result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
i__1 = n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = t2_subscr(i__, j);
if (t2[i__3].r != 0.f || t2[i__3].i != 0.f) {
res += 1.f / eps;
}
/* L100: */
}
/* L110: */
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of CGET36 */
} /* cget36_ */
/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *taua,
complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
integer *ldb, complex *taub, complex *work, integer *lwork, real *
rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
real r__1;
complex q__1;
/* Local variables */
static integer info;
static real unfl;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm, bnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), cungqr_(integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *), cungrq_(integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
static real ulp;
#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 r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___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 af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
#define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1
#define bf_ref(a_1,a_2) bf[bf_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
=======
CGRQTS tests CGGRQF, which computes the GRQ factorization of an
M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The M-by-N matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the GRQ factorization of A and B, as returned
by CGGRQF, see CGGRQF for further details.
Q (output) COMPLEX array, dimension (LDA,N)
The N-by-N unitary matrix Q.
R (workspace) COMPLEX array, dimension (LDA,MAX(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, R and Q.
LDA >= max(M,N).
TAUA (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by SGGQRC.
B (input) COMPLEX array, dimension (LDB,N)
On entry, the P-by-N matrix A.
BF (output) COMPLEX array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by CGGRQF, see CGGRQF for further details.
Z (output) REAL array, dimension (LDB,P)
The P-by-P unitary matrix Z.
T (workspace) COMPLEX array, dimension (LDB,max(P,N))
BWK (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) COMPLEX array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by SGGRQF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK, LWORK >= max(M,P,N)**2.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (4)
The test ratios:
RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
=====================================================================
Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1 * 1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1 * 1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = slamch_("Precision");
unfl = slamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
cggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1,
1), lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, &
q_ref(*n - *m + 2, *n - *m + 1), lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, &
q_ref(2, 1), lda);
}
}
i__1 = min(*m,*n);
cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb);
}
i__1 = min(*p,*n);
cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
clacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n -
*m + 1), lda);
} else {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
clacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n
+ 1, 1), lda);
}
/* Copy T */
claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__1, &a[a_offset]
, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.f;
}
/* Compute T*Q - Z'*B */
cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
cherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (real) max(1,*n) / ulp;
/* Compute I - Z'*Z */
claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
cherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
return 0;
/* End of CGRQTS */
} /* cgrqts_ */
/* 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 cdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, complex *a, integer *lda, complex *h__, complex *w,
complex *w1, complex *vl, integer *ldvl, complex *vr, integer *ldvr,
complex *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
scale1, real *result, complex *work, integer *nwork, real *rwork,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
static char bal[1*4] = "N" "P" "S" "B";
/* Format strings */
static char fmt_9992[] = "(\002 CDRVVX: \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_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
"see CDRVVX for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
"22=Matrix read from input file\002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
"|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
"/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
"/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
"mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
"matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
" = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
"p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
"tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
"= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
"= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
"WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
"\002, test(\002,i2,\002)=\002,g10.3)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer i__, j, n;
real wi, wr;
integer iwk;
real ulp;
integer ibal;
real cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
integer isrt;
logical badnn;
extern /* Subroutine */ int cget23_(logical *, integer *, char *, integer
*, real *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, complex *, integer *,
real *, integer *);
integer nfail, imode, iinfo;
real conds, anorm;
integer jsize, nerrs, itype, jtype, ntest;
real rtulp;
char balanc[1];
extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
char *, integer *, complex *, integer *, real *, complex *, char *
, char *, char *, char *, real *, integer *, real *, integer *,
integer *, real *, complex *, integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer idumma[1];
integer ioldsd[4];
extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
*, char *, complex *, integer *, real *, complex *, char *, char *
, complex *, integer *, real *, complex *, integer *, real *,
char *, integer *, integer *, integer *, real *, real *, char *,
complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*);
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
real ulpinv;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___45 = { 0, 0, 1, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___54 = { 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_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVVX checks the nonsymmetric eigenvalue problem expert driver */
/* CGEEVX. */
/* CDRVVX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When CDRVVX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified in the calling sequence. */
/* For each size ("n") and each type of matrix, one matrix will be */
/* generated and used to test the nonsymmetric eigenroutines. For */
/* each matrix, 9 tests will be performed: */
/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
/* Here VR is the matrix of unit right eigenvectors. */
/* W is a diagonal matrix with diagonal entries W(j). */
/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
/* Here VL is the matrix of unit left eigenvectors, A**H is the */
/* conjugate transpose of A, and W is as above. */
/* (3) | |VR(i)| - 1 | / ulp and largest component real */
/* VR(i) denotes the i-th column of VR. */
/* (4) | |VL(i)| - 1 | / ulp and largest component real */
/* VL(i) denotes the i-th column of VL. */
/* (5) W(full) = W(partial) */
/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
/* and RCONDE are also computed, and W(partial) denotes the */
/* eigenvalues computed when only some of VR, VL, RCONDV, and */
/* RCONDE are computed. */
/* (6) VR(full) = VR(partial) */
/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
/* and RCONDE are computed, and VR(partial) denotes the result */
/* when only some of VL and RCONDV are computed. */
/* (7) VL(full) = VL(partial) */
/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
/* and RCONDE are computed, and VL(partial) denotes the result */
/* when only some of VR and RCONDV are computed. */
/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
/* SCALE, ILO, IHI, ABNRM (partial) */
/* 1/ulp otherwise */
/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
/* (partial) is when some are not computed. */
/* (9) RCONDV(full) = RCONDV(partial) */
/* RCONDV(full) denotes the reciprocal condition numbers of the */
/* right eigenvectors computed when VR, VL and RCONDE are also */
/* computed. RCONDV(partial) denotes the reciprocal condition */
/* numbers when only some of VR, VL and RCONDE are computed. */
/* The "sizes" 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) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalues */
/* and right eigenvectors. For these matrices, in addition to tests */
/* (1) to (9) we will compute the following two tests: */
/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right eigenvector condition number */
/* computed by CGEEVX and RCDVIN (the precomputed true value) */
/* is supplied as input. cond(RCONDV) is the condition number of */
/* RCONDV, and takes errors in computing RCONDV into account, so */
/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
/* essentially given by norm(A)/RCONDE. */
/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal eigenvalue condition number */
/* computed by CGEEVX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* 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. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. 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 CDRVVX 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. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (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 array, dimension (LDA, max(NN,12)) */
/* 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, and H. LDA must be at */
/* least 1 and at least max( NN, 12 ). (12 is the */
/* dimension of the largest matrix on the precomputed */
/* input file.) */
/* H (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
/* Another copy of the test matrix A, modified by CGEEVX. */
/* W (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Contains the eigenvalues of A. */
/* W1 (workspace) COMPLEX array, dimension (max(NN,12)) */
/* Like W, this array contains the eigenvalues of A, */
/* but those computed when CGEEVX only computes a partial */
/* eigendecomposition, i.e. not the eigenvalues and left */
/* and right eigenvectors. */
/* VL (workspace) COMPLEX array, dimension (LDVL, max(NN,12)) */
/* VL holds the computed left eigenvectors. */
/* LDVL (input) INTEGER */
/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
/* VR (workspace) COMPLEX array, dimension (LDVR, max(NN,12)) */
/* VR holds the computed right eigenvectors. */
/* LDVR (input) INTEGER */
/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
/* LRE (workspace) COMPLEX array, dimension (LDLRE, max(NN,12)) */
/* LRE holds the computed right or left eigenvectors. */
/* LDLRE (input) INTEGER */
/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
/* RESULT (output) REAL array, dimension (11) */
/* The values computed by the seven tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* WORK (workspace) COMPLEX array, dimension (NWORK) */
/* NWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
/* RWORK (workspace) REAL array, dimension (2*max(NN,12)) */
/* INFO (output) INTEGER */
/* If 0, then successful exit. */
/* If <0, then input paramter -INFO is incorrect. */
/* If >0, CLATMR, CLATMS, CLATME or CGET23 returned an error */
/* code, and INFO is its absolute value. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN or 12. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--rwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 7 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 7;
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: */
}
/* 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 (*ldvl < 1 || *ldvl < nmax) {
*info = -15;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -17;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -19;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -30;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVVX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L160;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L140;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
&iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
if (n >= 4) {
claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
, lda);
i__3 = n - 3;
claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
a_dim1 + 3], lda);
claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
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;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 3; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = (n << 1) + i__3 * i__3;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Test for all balancing options */
for (ibal = 1; ibal <= 4; ++ibal) {
*(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
1];
/* Perform tests */
cget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
rcdein[1], &scale[1], &scale1[1], &result[1], &
work[1], &nnwork, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 9; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___40.ciunit = *nounit;
s_wsfe(&io___40);
e_wsfe();
io___41.ciunit = *nounit;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 9; ++j) {
if (result[j] >= *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, balanc, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
/* L130: */
}
L140:
;
}
/* L150: */
}
L160:
/* Read in data from file to check accuracy of condition estimation. */
/* Assume input eigenvalues are sorted lexicographically (increasing */
/* by real part, then decreasing by imaginary part) */
jtype = 0;
L170:
io___45.ciunit = *niunit;
i__1 = s_rsle(&io___45);
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L220;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L220;
}
/* Read input data until N=0 */
if (n == 0) {
goto L220;
}
++jtype;
iseed[1] = jtype;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___48.ciunit = *niunit;
s_rsle(&io___48);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L180: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
do_lio(&c__4, &c__1, (char *)&wr, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wi, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
e_rsle();
i__2 = i__;
q__1.r = wr, q__1.i = wi;
w1[i__2].r = q__1.r, w1[i__2].i = q__1.i;
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
cget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 11; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L200: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
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, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
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__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L210: */
}
nerrs += nfail;
ntestt += ntest;
goto L170;
L220:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of CDRVVX */
} /* cdrvvx_ */
/* Subroutine */ int cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
selctg, integer *n, complex *a, integer *lda, complex *b, integer *
ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl,
integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *
lwork, real *rwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real dif[2];
integer ihi, ilo;
real eps, anrm, bnrm;
integer idum[1], ierr, itau, iwrk;
real pvsl, pvsr;
extern logical lsame_(char *, char *);
integer ileft, icols;
logical cursl, ilvsl, ilvsr;
integer irwrk, irows;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *), slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, 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 *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *),
ctgsen_(integer *, logical *, logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, complex *,
complex *, integer *, complex *, integer *, integer *, real *,
real *, real *, complex *, integer *, integer *, integer *,
integer *);
integer ijobvl, iright, ijobvr;
real anrmto;
integer lwkmin;
logical lastsl;
real bnrmto;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
cunmqr_(char *, char *, integer *, integer *, integer *, complex
*, integer *, complex *, complex *, integer *, complex *, integer
*, integer *);
real smlnum;
logical wantst, lquery;
integer lwkopt;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGES computes for a pair of N-by-N complex nonsymmetric matrices */
/* (A,B), the generalized eigenvalues, the generalized complex Schur */
/* form (S, T), and optionally left and/or right Schur vectors (VSL */
/* and VSR). This gives the generalized Schur factorization */
/* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) */
/* where (VSR)**H is the conjugate-transpose of VSR. */
/* Optionally, it also orders the eigenvalues so that a selected cluster */
/* of eigenvalues appears in the leading diagonal blocks of the upper */
/* triangular matrix S and the upper triangular matrix T. The leading */
/* columns of VSL and VSR then form an unitary basis for the */
/* corresponding left and right eigenspaces (deflating subspaces). */
/* (If only the generalized eigenvalues are needed, use the driver */
/* CGGEV instead, which is faster.) */
/* 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 a */
/* reasonable interpretation for beta=0, and even for both being zero. */
/* A pair of matrices (S,T) is in generalized complex Schur form if S */
/* and T are upper triangular and, in addition, the diagonal elements */
/* of T are non-negative real numbers. */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors. */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the generalized Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELCTG). */
/* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments */
/* SELCTG must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'N', SELCTG is not referenced. */
/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* An eigenvalue ALPHA(j)/BETA(j) is selected if */
/* SELCTG(ALPHA(j),BETA(j)) is true. */
/* Note that a selected complex eigenvalue may no longer satisfy */
/* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned), in this */
/* case INFO is set to N+2 (See INFO below). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the first of the pair of matrices. */
/* On exit, A has been overwritten by its generalized Schur */
/* form S. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the second of the pair of matrices. */
/* On exit, B has been overwritten by its generalized Schur */
/* form T. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELCTG is true. */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* BETA (output) COMPLEX array, dimension (N) */
/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
/* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), */
/* j=1,...,N are the diagonals of the complex Schur form (A,B) */
/* output by CGGES. The BETA(j) will be non-negative real. */
/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
/* underflow, and BETA(j) may even be zero. Thus, the user */
/* should avoid naively computing the ratio alpha/beta. */
/* However, ALPHA will be always less than and usually */
/* comparable with norm(A) in magnitude, and BETA always less */
/* than and usually comparable with norm(B). */
/* VSL (output) COMPLEX array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) COMPLEX array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (8*N) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* Not referenced if SORT = 'N'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* =1,...,N: */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHA(j) and BETA(j) should be correct for */
/* j=INFO+1,...,N. */
/* > N: =N+1: other than QZ iteration failed in CHGEQZ */
/* =N+2: after reordering, roundoff changed values of */
/* some complex eigenvalues so that leading */
/* eigenvalues in the Generalized Schur form no */
/* longer satisfy SELCTG=.TRUE. This could also */
/* be caused due to scaling. */
/* =N+3: reordering falied in CTGSEN. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
--rwork;
--bwork;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
wantst = lsame_(sort, "S");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -3;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -14;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -16;
}
/* 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.) */
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwkmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n,
&c__0);
lwkopt = max(i__1,i__2);
/* Computing MAX */
i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNMQR", " ", n, &
c__1, n, &c_n1);
lwkopt = max(i__1,i__2);
if (ilvsl) {
/* Computing MAX */
i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR", " ", n, &
c__1, n, &c_n1);
lwkopt = max(i__1,i__2);
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
if (*lwork < lwkmin && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGES ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (Real Workspace: need 6*N) */
ileft = 1;
iright = *n + 1;
irwrk = iright + *n;
cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
ileft], &rwork[iright], &rwork[irwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B) */
/* (Complex Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwrk], &i__1, &ierr);
/* Apply the orthogonal transformation to matrix A */
/* (Complex Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
ierr);
/* Initialize VSL */
/* (Complex Workspace: need N, prefer N*NB) */
if (ilvsl) {
claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
if (irows > 1) {
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
ilo + 1 + ilo * vsl_dim1], ldvsl);
}
i__1 = *lwork + 1 - iwrk;
cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwrk], &i__1, &ierr);
}
/* Initialize VSR */
if (ilvsr) {
claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
/* (Workspace: none needed) */
cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
*sdim = 0;
/* Perform QZ algorithm, computing Schur vectors if desired */
/* (Complex Workspace: need N) */
/* (Real Workspace: need N) */
iwrk = itau;
i__1 = *lwork + 1 - iwrk;
chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L30;
}
/* Sort eigenvalues ALPHA/BETA if desired */
/* (Workspace: none needed) */
if (wantst) {
/* Undo scaling on eigenvalues before selecting */
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, &c__1, &alpha[1], n,
&ierr);
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, &c__1, &beta[1], n,
&ierr);
}
/* Select eigenvalues */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
/* L10: */
}
i__1 = *lwork - iwrk + 1;
ctgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
&vsr[vsr_offset], ldvsr, sdim, &pvsl, &pvsr, dif, &work[iwrk],
&i__1, idum, &c__1, &ierr);
if (ierr == 1) {
*info = *n + 3;
}
}
/* Apply back-permutation to VSL and VSR */
/* (Workspace: none needed) */
if (ilvsl) {
cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsl[vsl_offset], ldvsl, &ierr);
}
if (ilvsr) {
cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsr[vsr_offset], ldvsr, &ierr);
}
/* Undo scaling */
if (ilascl) {
clascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
ierr);
clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
ierr);
}
if (ilbscl) {
clascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
ierr);
clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
if (wantst) {
/* Check if reordering is correct */
lastsl = TRUE_;
*sdim = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*selctg)(&alpha[i__], &beta[i__]);
if (cursl) {
++(*sdim);
}
if (cursl && ! lastsl) {
*info = *n + 2;
}
lastsl = cursl;
/* L20: */
}
}
L30:
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CGGES */
} /* cgges_ */
/* 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 chbtrd_(char *vect, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *
ldq, complex *work, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
integer i__, j, k, l;
complex t;
integer i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, kdm1, inca,
jend, lend, jinc;
real abst;
integer incx, last;
complex temp;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
integer j1end, j1inc;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
integer iqend;
extern logical lsame_(char *, char *);
logical initq, wantq, upper;
extern /* Subroutine */ int clar2v_(integer *, complex *, complex *,
complex *, integer *, real *, complex *, integer *), clacgv_(
integer *, complex *, integer *);
integer iqaend;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), clartg_(complex *,
complex *, real *, complex *, complex *), xerbla_(char *, integer
*), clargv_(integer *, complex *, integer *, complex *,
integer *, real *, integer *), clartv_(integer *, complex *,
integer *, complex *, integer *, real *, complex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBTRD reduces a complex Hermitian band matrix A to real symmetric */
/* tridiagonal form T by a unitary similarity transformation: */
/* Q**H * A * Q = T. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'N': do not form Q; */
/* = 'V': form Q; */
/* = 'U': update a matrix X, by forming X*Q. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, the diagonal elements of AB are overwritten by the */
/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
/* elements on the first superdiagonal (if UPLO = 'U') or the */
/* first subdiagonal (if UPLO = 'L') are overwritten by the */
/* off-diagonal elements of T; the rest of AB is overwritten by */
/* values generated during the reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* D (output) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T. */
/* E (output) REAL array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if VECT = 'U', then Q must contain an N-by-N */
/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
/* On exit: */
/* if VECT = 'V', Q contains the N-by-N unitary matrix Q; */
/* if VECT = 'U', Q contains the product X*Q; */
/* if VECT = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* Modified by Linda Kaufman, Bell Labs. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initq = lsame_(vect, "V");
wantq = initq || lsame_(vect, "U");
upper = lsame_(uplo, "U");
kd1 = *kd + 1;
kdm1 = *kd - 1;
incx = *ldab - 1;
iqend = 1;
*info = 0;
if (! wantq && ! lsame_(vect, "N")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < kd1) {
*info = -6;
} else if (*ldq < max(1,*n) && wantq) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize Q to the unit matrix, if needed */
if (initq) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KD1. */
/* The real cosines and complex sines of the plane rotations are */
/* stored in the arrays D and WORK. */
inca = kd1 * *ldab;
/* Computing MIN */
i__1 = *n - 1;
kdn = min(i__1,*kd);
if (upper) {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the upper triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = kd1 + ab_dim1;
i__2 = kd1 + ab_dim1;
r__1 = ab[i__2].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th row of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr >= (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
clartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
&inca, &ab[l + j1 * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
/* L10: */
}
} else {
jend = j1 + (nr - 1) * kd1;
i__2 = jend;
i__3 = kd1;
for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
i__2; jinc += i__3) {
crot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
c__1, &ab[jinc * ab_dim1 + 1], &c__1,
&d__[jinc], &work[jinc]);
/* L20: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+k-1) */
/* within the band */
clartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
, &ab[*kd - k + 2 + (i__ + k - 1) *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__3 = *kd - k + 3 + (i__ + k - 2) * ab_dim1;
ab[i__3].r = temp.r, ab[i__3].i = temp.i;
/* apply rotation from the right */
i__3 = k - 3;
crot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
k - 1) * ab_dim1], &c__1, &d__[i__ + k -
1], &work[i__ + k - 1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
&d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the left */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if ((*kd << 1) - 1 < nr) {
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[*kd - l + (j1 + l) *
ab_dim1], &inca, &ab[*kd - l + 1
+ (j1 + l) * ab_dim1], &inca, &
d__[j1], &work[j1], &kd1);
}
/* L30: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__3 = j1end;
i__2 = kd1;
for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
i__3; jin += i__2) {
i__4 = *kd - 1;
crot_(&i__4, &ab[*kd - 1 + (jin + 1) *
ab_dim1], &incx, &ab[*kd + (jin +
1) * ab_dim1], &incx, &d__[jin], &
work[jin]);
/* L40: */
}
}
/* Computing MIN */
i__2 = kdm1, i__3 = *n - j2;
lend = min(i__2,i__3);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[*kd - 1 + (last + 1) *
ab_dim1], &incx, &ab[*kd + (last + 1)
* ab_dim1], &incx, &d__[last], &work[
last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__2 = 0, i__3 = k - 3;
i2 = max(i__2,i__3);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
r_cnjg(&q__1, &work[j]);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&q__1);
/* L50: */
}
} else {
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
r_cnjg(&q__1, &work[j]);
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
q__1);
/* L60: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
{
/* create nonzero element a(j-1,j+kd) outside the band */
/* and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = (j + *kd) * ab_dim1 + 1;
i__5 = j;
i__6 = (j + *kd) * ab_dim1 + 1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
/* L90: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = *kd + (i__ + 1) * ab_dim1;
t.r = ab[i__3].r, t.i = ab[i__3].i;
abst = c_abs(&t);
i__3 = *kd + (i__ + 1) * ab_dim1;
ab[i__3].r = abst, ab[i__3].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__3 = *kd + (i__ + 2) * ab_dim1;
i__2 = *kd + (i__ + 2) * ab_dim1;
q__1.r = ab[i__2].r * t.r - ab[i__2].i * t.i, q__1.i = ab[
i__2].r * t.i + ab[i__2].i * t.r;
ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &t);
cscal_(n, &q__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L100: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L110: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = i__;
i__2 = kd1 + i__ * ab_dim1;
d__[i__3] = ab[i__2].r;
/* L120: */
}
} else {
if (*kd > 1) {
/* Reduce to complex Hermitian tridiagonal form, working with */
/* the lower triangle */
nr = 0;
j1 = kdn + 2;
j2 = 1;
i__1 = ab_dim1 + 1;
i__3 = ab_dim1 + 1;
r__1 = ab[i__3].r;
ab[i__1].r = r__1, ab[i__1].i = 0.f;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column of matrix to tridiagonal form */
for (k = kdn + 1; k >= 2; --k) {
j1 += kdn;
j2 += kdn;
if (nr > 0) {
/* generate plane rotations to annihilate nonzero */
/* elements which have been created outside the band */
clargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
work[j1], &kd1, &d__[j1], &kd1);
/* apply plane rotations from one side */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > (*kd << 1) - 1) {
i__3 = *kd - 1;
for (l = 1; l <= i__3; ++l) {
clartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
ab_dim1], &inca, &ab[kd1 - l + 1 + (
j1 - kd1 + l) * ab_dim1], &inca, &d__[
j1], &work[j1], &kd1);
/* L130: */
}
} else {
jend = j1 + kd1 * (nr - 1);
i__3 = jend;
i__2 = kd1;
for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
i__3; jinc += i__2) {
crot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
, &incx, &ab[kd1 + (jinc - *kd) *
ab_dim1], &incx, &d__[jinc], &work[
jinc]);
/* L140: */
}
}
}
if (k > 2) {
if (k <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i+k-1,i) */
/* within the band */
clartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
ab_dim1], &d__[i__ + k - 1], &work[i__ +
k - 1], &temp);
i__2 = k - 1 + i__ * ab_dim1;
ab[i__2].r = temp.r, ab[i__2].i = temp.i;
/* apply rotation from the left */
i__2 = k - 3;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
crot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
i__4, &d__[i__ + k - 1], &work[i__ + k -
1]);
}
++nr;
j1 = j1 - kdn - 1;
}
/* apply plane rotations from both sides to diagonal */
/* blocks */
if (nr > 0) {
clar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
inca, &d__[j1], &work[j1], &kd1);
}
/* apply plane rotations from the right */
/* Dependent on the the number of diagonals either */
/* CLARTV or CROT is used */
if (nr > 0) {
clacgv_(&nr, &work[j1], &kd1);
if (nr > (*kd << 1) - 1) {
i__2 = *kd - 1;
for (l = 1; l <= i__2; ++l) {
if (j2 + l > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 2 + (j1 - 1) *
ab_dim1], &inca, &ab[l + 1 + j1 *
ab_dim1], &inca, &d__[j1], &work[
j1], &kd1);
}
/* L150: */
}
} else {
j1end = j1 + kd1 * (nr - 2);
if (j1end >= j1) {
i__2 = j1end;
i__3 = kd1;
for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
j1inc <= i__2; j1inc += i__3) {
crot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
3], &c__1, &ab[j1inc * ab_dim1 +
2], &c__1, &d__[j1inc], &work[
j1inc]);
/* L160: */
}
}
/* Computing MIN */
i__3 = kdm1, i__2 = *n - j2;
lend = min(i__3,i__2);
last = j1end + kd1;
if (lend > 0) {
crot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
c__1, &ab[last * ab_dim1 + 2], &c__1,
&d__[last], &work[last]);
}
}
}
if (wantq) {
/* accumulate product of plane rotations in Q */
if (initq) {
/* take advantage of the fact that Q was */
/* initially the Identity matrix */
iqend = max(iqend,j2);
/* Computing MAX */
i__3 = 0, i__2 = k - 3;
i2 = max(i__3,i__2);
iqaend = i__ * *kd + 1;
if (k == 2) {
iqaend += *kd;
}
iqaend = min(iqaend,iqend);
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+= i__2) {
ibl = i__ - i2 / kdm1;
++i2;
/* Computing MAX */
i__4 = 1, i__5 = j - ibl;
iqb = max(i__4,i__5);
nq = iqaend + 1 - iqb;
/* Computing MIN */
i__4 = iqaend + *kd;
iqaend = min(i__4,iqend);
crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
&q[iqb + j * q_dim1], &c__1, &d__[j],
&work[j]);
/* L170: */
}
} else {
i__2 = j2;
i__3 = kd1;
for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+= i__3) {
crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
j * q_dim1 + 1], &c__1, &d__[j], &
work[j]);
/* L180: */
}
}
}
if (j2 + kdn > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 = j2 - kdn - 1;
}
i__3 = j2;
i__2 = kd1;
for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
{
/* create nonzero element a(j+kd,j-1) outside the */
/* band and store it in WORK */
i__4 = j + *kd;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
.i + work[i__5].i * ab[i__6].r;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
i__4 = kd1 + j * ab_dim1;
i__5 = j;
i__6 = kd1 + j * ab_dim1;
q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
ab[i__6].i;
ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
/* L190: */
}
/* L200: */
}
/* L210: */
}
}
if (*kd > 0) {
/* make off-diagonal elements real and copy them to E */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * ab_dim1 + 2;
t.r = ab[i__2].r, t.i = ab[i__2].i;
abst = c_abs(&t);
i__2 = i__ * ab_dim1 + 2;
ab[i__2].r = abst, ab[i__2].i = 0.f;
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (i__ < *n - 1) {
i__2 = (i__ + 1) * ab_dim1 + 2;
i__3 = (i__ + 1) * ab_dim1 + 2;
q__1.r = ab[i__3].r * t.r - ab[i__3].i * t.i, q__1.i = ab[
i__3].r * t.i + ab[i__3].i * t.r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
cscal_(n, &t, &q[(i__ + 1) * q_dim1 + 1], &c__1);
}
/* L220: */
}
} else {
/* set E to zero if original matrix was diagonal */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L230: */
}
}
/* copy diagonal elements to D */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ * ab_dim1 + 1;
d__[i__2] = ab[i__3].r;
/* L240: */
}
}
return 0;
/* End of CHBTRD */
} /* chbtrd_ */
/* Subroutine */ int cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
selctg, char *sense, integer *n, complex *a, integer *lda, complex *b,
integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *
vsl, integer *ldvsl, complex *vsr, integer *ldvsr, real *rconde, real
*rcondv, complex *work, integer *lwork, real *rwork, integer *iwork,
integer *liwork, logical *bwork, integer *info)
{
/* -- LAPACK driver 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
=======
CGGESX computes for a pair of N-by-N complex nonsymmetric matrices
(A,B), the generalized eigenvalues, the complex Schur form (S,T),
and, optionally, the left and/or right matrices of Schur vectors (VSL
and VSR). This gives the generalized Schur factorization
(A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
where (VSR)**H is the conjugate-transpose of VSR.
Optionally, it also orders the eigenvalues so that a selected cluster
of eigenvalues appears in the leading diagonal blocks of the upper
triangular matrix S and the upper triangular matrix T; computes
a reciprocal condition number for the average of the selected
eigenvalues (RCONDE); and computes a reciprocal condition number for
the right and left deflating subspaces corresponding to the selected
eigenvalues (RCONDV). The leading columns of VSL and VSR then form
an orthonormal basis for the corresponding left and right eigenspaces
(deflating subspaces).
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 a
reasonable interpretation for beta=0 or for both being zero.
A pair of matrices (S,T) is in generalized complex Schur form if T is
upper triangular with non-negative diagonal and S is upper
triangular.
Arguments
=========
JOBVSL (input) CHARACTER*1
= 'N': do not compute the left Schur vectors;
= 'V': compute the left Schur vectors.
JOBVSR (input) CHARACTER*1
= 'N': do not compute the right Schur vectors;
= 'V': compute the right Schur vectors.
SORT (input) CHARACTER*1
Specifies whether or not to order the eigenvalues on the
diagonal of the generalized Schur form.
= 'N': Eigenvalues are not ordered;
= 'S': Eigenvalues are ordered (see SELCTG).
SELCTG (input) LOGICAL FUNCTION of two COMPLEX arguments
SELCTG must be declared EXTERNAL in the calling subroutine.
If SORT = 'N', SELCTG is not referenced.
If SORT = 'S', SELCTG is used to select eigenvalues to sort
to the top left of the Schur form.
Note that a selected complex eigenvalue may no longer satisfy
SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
ordering may change the value of complex eigenvalues
(especially if the eigenvalue is ill-conditioned), in this
case INFO is set to N+3 see INFO below).
SENSE (input) CHARACTER
Determines which reciprocal condition numbers are computed.
= 'N' : None are computed;
= 'E' : Computed for average of selected eigenvalues only;
= 'V' : Computed for selected deflating subspaces only;
= 'B' : Computed for both.
If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the first of the pair of matrices.
On exit, A has been overwritten by its generalized Schur
form S.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the second of the pair of matrices.
On exit, B has been overwritten by its generalized Schur
form T.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
SDIM (output) INTEGER
If SORT = 'N', SDIM = 0.
If SORT = 'S', SDIM = number of eigenvalues (after sorting)
for which SELCTG is true.
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are
the diagonals of the complex Schur form (S,T). BETA(j) will
be non-negative real.
Note: the quotients ALPHA(j)/BETA(j) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio alpha/beta.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VSL (output) COMPLEX array, dimension (LDVSL,N)
If JOBVSL = 'V', VSL will contain the left Schur vectors.
Not referenced if JOBVSL = 'N'.
LDVSL (input) INTEGER
The leading dimension of the matrix VSL. LDVSL >=1, and
if JOBVSL = 'V', LDVSL >= N.
VSR (output) COMPLEX array, dimension (LDVSR,N)
If JOBVSR = 'V', VSR will contain the right Schur vectors.
Not referenced if JOBVSR = 'N'.
LDVSR (input) INTEGER
The leading dimension of the matrix VSR. LDVSR >= 1, and
if JOBVSR = 'V', LDVSR >= N.
RCONDE (output) REAL array, dimension ( 2 )
If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
reciprocal condition numbers for the average of the selected
eigenvalues.
Not referenced if SENSE = 'N' or 'V'.
RCONDV (output) REAL array, dimension ( 2 )
If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
reciprocal condition number for the selected deflating
subspaces.
Not referenced if SENSE = 'N' or 'E'.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 2*N.
If SENSE = 'E', 'V', or 'B',
LWORK >= MAX(2*N, 2*SDIM*(N-SDIM)).
RWORK (workspace) REAL array, dimension ( 8*N )
Real workspace.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
Not referenced if SENSE = 'N'.
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array WORK. LIWORK >= N+2.
BWORK (workspace) LOGICAL array, dimension (N)
Not referenced if SORT = 'N'.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. (A,B) are not in Schur
form, but ALPHA(j) and BETA(j) should be correct for
j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in CHGEQZ
=N+2: after reordering, roundoff changed values of
some complex eigenvalues so that leading
eigenvalues in the Generalized Schur form no
longer satisfy SELCTG=.TRUE. This could also
be caused due to scaling.
=N+3: reordering failed in CTGSEN.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c__0 = 0;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ijob;
static real anrm, bnrm;
static integer ierr, itau, iwrk, i__;
extern logical lsame_(char *, char *);
static integer ileft, icols;
static logical cursl, ilvsl, ilvsr;
static integer irwrk, irows;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *), slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static real pl;
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
static real pr;
static logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *);
static real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *),
ctgsen_(integer *, logical *, logical *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, complex *,
complex *, integer *, complex *, integer *, integer *, real *,
real *, real *, complex *, integer *, integer *, integer *,
integer *);
static integer ijobvl, iright, ijobvr;
static logical wantsb;
static integer liwmin;
static logical wantse, lastsl;
static real anrmto, bnrmto;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static integer minwrk, maxwrk;
static logical wantsn;
static real smlnum;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static logical wantst, wantsv;
static real dif[2];
static integer ihi, ilo;
static real eps;
#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 vsl_subscr(a_1,a_2) (a_2)*vsl_dim1 + a_1
#define vsl_ref(a_1,a_2) vsl[vsl_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1 * 1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1 * 1;
vsr -= vsr_offset;
--rconde;
--rcondv;
--work;
--rwork;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
if (wantsn) {
ijob = 0;
iwork[1] = 1;
} else if (wantse) {
ijob = 1;
} else if (wantsv) {
ijob = 2;
} else if (wantsb) {
ijob = 4;
}
/* Test the input arguments */
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -3;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -15;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*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 = *n << 1;
minwrk = max(i__1,i__2);
maxwrk = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0, (
ftnlen)6, (ftnlen)1);
if (ilvsl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR", " ", n, &
c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (! wantsn) {
liwmin = *n + 2;
} else {
liwmin = 1;
}
iwork[1] = liwmin;
if (*info == 0 && *lwork < minwrk) {
*info = -21;
} else if (*info == 0 && ijob >= 1) {
if (*liwork < liwmin) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrix to make it more nearly triangular
(Real Workspace: need 6*N) */
ileft = 1;
iright = *n + 1;
irwrk = iright + *n;
cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
ileft], &rwork[iright], &rwork[irwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B)
(Complex Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
cgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Apply the unitary transformation to matrix A
(Complex Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VSL
(Complex Workspace: need N, prefer N*NB) */
if (ilvsl) {
claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vsl_ref(ilo +
1, ilo), ldvsl);
i__1 = *lwork + 1 - iwrk;
cungqr_(&irows, &irows, &irows, &vsl_ref(ilo, ilo), ldvsl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
/* Initialize VSR */
if (ilvsr) {
claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
*sdim = 0;
/* Perform QZ algorithm, computing Schur vectors if desired
(Complex Workspace: need N)
(Real Workspace: need N) */
iwrk = itau;
i__1 = *lwork + 1 - iwrk;
chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L40;
}
/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
condition number(s) */
if (wantst) {
/* Undo scaling on eigenvalues before SELCTGing */
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n,
&ierr);
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
&ierr);
}
/* Select eigenvalues */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
/* L10: */
}
/* Reorder eigenvalues, transform Generalized Schur vectors, and
compute reciprocal condition numbers
(Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM))
otherwise, need 1 ) */
i__1 = *lwork - iwrk + 1;
ctgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
&vsr[vsr_offset], ldvsr, sdim, &pl, &pr, dif, &work[iwrk], &
i__1, &iwork[1], liwork, &ierr);
if (ijob >= 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (ierr == -21) {
/* not enough complex workspace */
*info = -21;
} else {
rconde[1] = pl;
rconde[2] = pl;
rcondv[1] = dif[0];
rcondv[2] = dif[1];
if (ierr == 1) {
*info = *n + 3;
}
}
}
/* Apply permutation to VSL and VSR
(Workspace: none needed) */
if (ilvsl) {
cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsl[vsl_offset], ldvsl, &ierr);
}
if (ilvsr) {
cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
vsr[vsr_offset], ldvsr, &ierr);
}
/* Undo scaling */
if (ilascl) {
clascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
ierr);
clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
ierr);
}
if (ilbscl) {
clascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
ierr);
clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
/* L20: */
if (wantst) {
/* Check if reordering is correct */
lastsl = TRUE_;
*sdim = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*selctg)(&alpha[i__], &beta[i__]);
if (cursl) {
++(*sdim);
}
if (cursl && ! lastsl) {
*info = *n + 2;
}
lastsl = cursl;
/* L30: */
}
}
L40:
work[1].r = (real) maxwrk, work[1].i = 0.f;
iwork[1] = liwmin;
return 0;
/* End of CGGESX */
} /* cggesx_ */
/* Subroutine */ int clqt03_(integer *m, integer *n, integer *k, complex *af,
complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static char side[1];
static integer info, j;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static integer iside;
extern logical lsame_(char *, char *);
static real resid, cnorm;
static char trans[1];
static integer mc, nc;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), clarnv_(integer *, integer *, integer *, complex *),
cunglq_(integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *, integer *), cunmlq_(char *, char
*, integer *, integer *, integer *, complex *, integer *, complex
*, complex *, integer *, complex *, integer *, integer *);
static integer itrans;
static real eps;
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___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 af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_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
=======
CLQT03 tests CUNMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
CLQT03 compares the results of a call to CUNMLQ with the results of
forming Q explicitly by a call to CUNGLQ and then performing matrix
multiplication by a call to CGEMM.
Arguments
=========
M (input) INTEGER
The number of rows or columns of the matrix C; C is n-by-m if
Q is applied from the left, or m-by-n if Q is applied from
the right. M >= 0.
N (input) INTEGER
The order of the orthogonal matrix Q. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
orthogonal matrix Q. N >= K >= 0.
AF (input) COMPLEX array, dimension (LDA,N)
Details of the LQ factorization of an m-by-n matrix, as
returned by CGELQF. See CGELQF for further details.
C (workspace) COMPLEX array, dimension (LDA,N)
CC (workspace) COMPLEX array, dimension (LDA,N)
Q (workspace) COMPLEX array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays AF, C, CC, and Q.
TAU (input) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors corresponding
to the LQ factorization in AF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The length of WORK. LWORK must be at least M, and should be
M*NB, where NB is the blocksize for this environment.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (4)
The test ratios compare two techniques for multiplying a
random matrix C by an n-by-n orthogonal matrix Q.
RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS )
RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS )
RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
=====================================================================
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1 * 1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = slamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
clacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)6, (ftnlen)6);
cunglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
clarnv_(&c__2, iseed, &mc, &c___ref(1, j));
/* L10: */
}
cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.f) {
cnorm = 1.f;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
/* Copy C */
clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "CUNMLQ", (ftnlen)6, (ftnlen)6);
cunmlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
cc[cc_offset], lda, &work[1], lwork, &info);
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
cc_offset], lda);
} else {
cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of CLQT03 */
} /* clqt03_ */
int cgbbrd_(char *vect, int *m, int *n, int *ncc,
int *kl, int *ku, complex *ab, int *ldab, float *d__,
float *e, complex *q, int *ldq, complex *pt, int *ldpt,
complex *c__, int *ldc, complex *work, float *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
complex q__1, q__2, q__3;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
int i__, j, l;
complex t;
int j1, j2, kb;
complex ra, rb;
float rc;
int kk, ml, nr, mu;
complex rs;
int kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
float abst;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *), cscal_(int *,
complex *, complex *, int *);
extern int lsame_(char *, char *);
int wantb, wantc;
int minmn;
int wantq;
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *), xerbla_(char *, int
*), clargv_(int *, complex *, int *, complex *,
int *, float *, int *), clartv_(int *, complex *,
int *, complex *, int *, float *, complex *, int *);
int wantpt;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBBRD reduces a complex general m-by-n band matrix A to float upper */
/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
/* The routine computes B, and optionally forms Q or P', or computes */
/* Q'*C for a given matrix C. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether or not the matrices Q and P' are to be */
/* formed. */
/* = 'N': do not form Q or P'; */
/* = 'Q': form Q only; */
/* = 'P': form P' only; */
/* = 'B': form both. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals of the matrix A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals of the matrix A. KU >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the m-by-n band matrix A, stored in rows 1 to */
/* KL+KU+1. The j-th column of A is stored in the j-th column of */
/* the array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for MAX(1,j-ku)<=i<=MIN(m,j+kl). */
/* On exit, A is overwritten by values generated during the */
/* reduction. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array A. LDAB >= KL+KU+1. */
/* D (output) REAL array, dimension (MIN(M,N)) */
/* The diagonal elements of the bidiagonal matrix B. */
/* E (output) REAL array, dimension (MIN(M,N)-1) */
/* The superdiagonal elements of the bidiagonal matrix B. */
/* Q (output) COMPLEX array, dimension (LDQ,M) */
/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
/* If VECT = 'N' or 'P', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= MAX(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
/* PT (output) COMPLEX array, dimension (LDPT,N) */
/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
/* If VECT = 'N' or 'Q', the array PT is not referenced. */
/* LDPT (input) INTEGER */
/* The leading dimension of the array PT. */
/* LDPT >= MAX(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
/* C (input/output) COMPLEX array, dimension (LDC,NCC) */
/* On entry, an m-by-ncc matrix C. */
/* On exit, C is overwritten by Q'*C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= MAX(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
/* WORK (workspace) COMPLEX array, dimension (MAX(M,N)) */
/* RWORK (workspace) REAL array, dimension (MAX(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--rwork;
/* Function Body */
wantb = lsame_(vect, "B");
wantq = lsame_(vect, "Q") || wantb;
wantpt = lsame_(vect, "P") || wantb;
wantc = *ncc > 0;
klu1 = *kl + *ku + 1;
*info = 0;
if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ncc < 0) {
*info = -4;
} else if (*kl < 0) {
*info = -5;
} else if (*ku < 0) {
*info = -6;
} else if (*ldab < klu1) {
*info = -8;
} else if (*ldq < 1 || wantq && *ldq < MAX(1,*m)) {
*info = -12;
} else if (*ldpt < 1 || wantpt && *ldpt < MAX(1,*n)) {
*info = -14;
} else if (*ldc < 1 || wantc && *ldc < MAX(1,*m)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
claset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (wantpt) {
claset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
minmn = MIN(*m,*n);
if (*kl + *ku > 1) {
/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
/* first to lower bidiagonal form and then transform to upper */
/* bidiagonal */
if (*ku > 0) {
ml0 = 1;
mu0 = 2;
} else {
ml0 = 2;
mu0 = 1;
}
/* Wherever possible, plane rotations are generated and applied in */
/* vector operations of length NR over the index set J1:J2:KLU1. */
/* The complex sines of the plane rotations are stored in WORK, */
/* and the float cosines in RWORK. */
/* Computing MIN */
i__1 = *m - 1;
klm = MIN(i__1,*kl);
/* Computing MIN */
i__1 = *n - 1;
kun = MIN(i__1,*ku);
kb = klm + kun;
kb1 = kb + 1;
inca = kb1 * *ldab;
nr = 0;
j1 = klm + 2;
j2 = 1 - kun;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Reduce i-th column and i-th row of matrix to bidiagonal form */
ml = klm + 1;
mu = kun + 1;
i__2 = kb;
for (kk = 1; kk <= i__2; ++kk) {
j1 += kb;
j2 += kb;
/* generate plane rotations to annihilate nonzero elements */
/* which have been created below the band */
if (nr > 0) {
clargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
&work[j1], &kb1, &rwork[j1], &kb1);
}
/* apply plane rotations from the left */
i__3 = kb;
for (l = 1; l <= i__3; ++l) {
if (j2 - klm + l - 1 > *n) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ l - 1) * ab_dim1], &inca, &rwork[j1], &work[
j1], &kb1);
}
/* L10: */
}
if (ml > ml0) {
if (ml <= *m - i__ + 1) {
/* generate plane rotation to annihilate a(i+ml-1,i) */
/* within the band, and apply rotation from the left */
clartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
work[i__ + ml - 1], &ra);
i__3 = *ku + ml - 1 + i__ * ab_dim1;
ab[i__3].r = ra.r, ab[i__3].i = ra.i;
if (i__ < *n) {
/* Computing MIN */
i__4 = *ku + ml - 2, i__5 = *n - i__;
i__3 = MIN(i__4,i__5);
i__6 = *ldab - 1;
i__7 = *ldab - 1;
crot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ 1) * ab_dim1], &i__7, &rwork[i__ + ml -
1], &work[i__ + ml - 1]);
}
}
++nr;
j1 -= kb1;
}
if (wantq) {
/* accumulate product of plane rotations in Q */
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
{
r_cnjg(&q__1, &work[j]);
crot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
q_dim1 + 1], &c__1, &rwork[j], &q__1);
/* L20: */
}
}
if (wantc) {
/* apply plane rotations to C */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
crot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
, ldc, &rwork[j], &work[j]);
/* L30: */
}
}
if (j2 + kun > *n) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j-1,j+ku) above the band */
/* and store it in WORK(n+1:2*n) */
i__5 = j + kun;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = (j + kun) * ab_dim1 + 1;
i__6 = j;
i__7 = (j + kun) * ab_dim1 + 1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L40: */
}
/* generate plane rotations to annihilate nonzero elements */
/* which have been generated above the band */
if (nr > 0) {
clargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
}
/* apply plane rotations from the right */
i__4 = kb;
for (l = 1; l <= i__4; ++l) {
if (j2 + l - 1 > *m) {
nrt = nr - 1;
} else {
nrt = nr;
}
if (nrt > 0) {
clartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
rwork[j1 + kun], &work[j1 + kun], &kb1);
}
/* L50: */
}
if (ml == ml0 && mu > mu0) {
if (mu <= *n - i__ + 1) {
/* generate plane rotation to annihilate a(i,i+mu-1) */
/* within the band, and apply rotation from the right */
clartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
&ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
&rwork[i__ + mu - 1], &work[i__ + mu - 1], &
ra);
i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
ab[i__4].r = ra.r, ab[i__4].i = ra.i;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = MIN(i__3,i__5);
crot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
- 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
&work[i__ + mu - 1]);
}
++nr;
j1 -= kb1;
}
if (wantpt) {
/* accumulate product of plane rotations in P' */
i__4 = j2;
i__3 = kb1;
for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
{
r_cnjg(&q__1, &work[j + kun]);
crot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
kun + pt_dim1], ldpt, &rwork[j + kun], &q__1);
/* L60: */
}
}
if (j2 + kb > *m) {
/* adjust J2 to keep within the bounds of the matrix */
--nr;
j2 -= kb1;
}
i__3 = j2;
i__4 = kb1;
for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
/* create nonzero element a(j+kl+ku,j+ku-1) below the */
/* band and store it in WORK(1:n) */
i__5 = j + kb;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
work[i__6].i * ab[i__7].r;
work[i__5].r = q__1.r, work[i__5].i = q__1.i;
i__5 = klu1 + (j + kun) * ab_dim1;
i__6 = j + kun;
i__7 = klu1 + (j + kun) * ab_dim1;
q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
ab[i__7].i;
ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to complex lower bidiagonal form */
/* Transform lower bidiagonal form to upper bidiagonal by applying */
/* plane rotations from the left, overwriting superdiagonal */
/* elements on subdiagonal elements */
/* Computing MIN */
i__2 = *m - 1;
i__1 = MIN(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
clartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
&ra);
i__2 = i__ * ab_dim1 + 1;
ab[i__2].r = ra.r, ab[i__2].i = ra.i;
if (i__ < *n) {
i__2 = i__ * ab_dim1 + 2;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, q__1.i = rs.r
* ab[i__4].i + rs.i * ab[i__4].r;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
i__2 = (i__ + 1) * ab_dim1 + 1;
i__4 = (i__ + 1) * ab_dim1 + 1;
q__1.r = rc * ab[i__4].r, q__1.i = rc * ab[i__4].i;
ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
}
if (wantq) {
r_cnjg(&q__1, &rs);
crot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
1], &c__1, &rc, &q__1);
}
if (wantc) {
crot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
ldc, &rc, &rs);
}
/* L100: */
}
} else {
/* A has been reduced to complex upper bidiagonal form or is */
/* diagonal */
if (*ku > 0 && *m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the */
/* right */
i__1 = *ku + (*m + 1) * ab_dim1;
rb.r = ab[i__1].r, rb.i = ab[i__1].i;
for (i__ = *m; i__ >= 1; --i__) {
clartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
i__1 = *ku + 1 + i__ * ab_dim1;
ab[i__1].r = ra.r, ab[i__1].i = ra.i;
if (i__ > 1) {
r_cnjg(&q__3, &rs);
q__2.r = -q__3.r, q__2.i = -q__3.i;
i__1 = *ku + i__ * ab_dim1;
q__1.r = q__2.r * ab[i__1].r - q__2.i * ab[i__1].i,
q__1.i = q__2.r * ab[i__1].i + q__2.i * ab[i__1]
.r;
rb.r = q__1.r, rb.i = q__1.i;
i__1 = *ku + i__ * ab_dim1;
i__2 = *ku + i__ * ab_dim1;
q__1.r = rc * ab[i__2].r, q__1.i = rc * ab[i__2].i;
ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
}
if (wantpt) {
r_cnjg(&q__1, &rs);
crot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
ldpt, &rc, &q__1);
}
/* L110: */
}
}
}
/* Make diagonal and superdiagonal elements float, storing them in D */
/* and E */
i__1 = *ku + 1 + ab_dim1;
t.r = ab[i__1].r, t.i = ab[i__1].i;
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
abst = c_abs(&t);
d__[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantq) {
cscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
}
if (wantc) {
r_cnjg(&q__1, &t);
cscal_(ncc, &q__1, &c__[i__ + c_dim1], ldc);
}
if (i__ < minmn) {
if (*ku == 0 && *kl == 0) {
e[i__] = 0.f;
i__2 = (i__ + 1) * ab_dim1 + 1;
t.r = ab[i__2].r, t.i = ab[i__2].i;
} else {
if (*ku == 0) {
i__2 = i__ * ab_dim1 + 2;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
} else {
i__2 = *ku + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
abst = c_abs(&t);
e[i__] = abst;
if (abst != 0.f) {
q__1.r = t.r / abst, q__1.i = t.i / abst;
t.r = q__1.r, t.i = q__1.i;
} else {
t.r = 1.f, t.i = 0.f;
}
if (wantpt) {
cscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
}
i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
r_cnjg(&q__2, &t);
q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i, q__1.i =
ab[i__2].r * q__2.i + ab[i__2].i * q__2.r;
t.r = q__1.r, t.i = q__1.i;
}
}
/* L120: */
}
return 0;
/* End of CGBBRD */
} /* cgbbrd_ */
/* 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 cggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, complex *a, integer *lda, complex *b, integer
*ldb, real *tola, real *tolb, integer *k, integer *l, complex *u,
integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
integer *iwork, real *rwork, complex *tau, complex *work, integer *
info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGGSVP computes unitary matrices U, V and Q such that
N-K-L K L
U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
L ( 0 0 A23 )
M-K-L ( 0 0 0 )
N-K-L K L
= K ( 0 A12 A13 ) if M-K-L < 0;
M-K ( 0 0 A23 )
N-K-L K L
V'*B*Q = L ( 0 0 B13 )
P-L ( 0 0 0 )
where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
conjugate transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
CGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Unitary matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Unitary matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Unitary matrix Q is computed;
= 'N': Q is not computed.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A contains the triangular (or trapezoidal) matrix
described in the Purpose section.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B contains the triangular matrix described in
the Purpose section.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TOLA (input) REAL
TOLB (input) REAL
TOLA and TOLB are the thresholds to determine the effective
numerical rank of matrix B and a subblock of A. Generally,
they are set to
TOLA = MAX(M,N)*norm(A)*MACHEPS,
TOLB = MAX(P,N)*norm(B)*MACHEPS.
The size of TOLA and TOLB may affect the size of backward
errors of the decomposition.
K (output) INTEGER
L (output) INTEGER
On exit, K and L specify the dimension of the subblocks
described in Purpose section.
K + L = effective numerical rank of (A',B')'.
U (output) COMPLEX array, dimension (LDU,M)
If JOBU = 'U', U contains the unitary matrix U.
If JOBU = 'N', U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M) if
JOBU = 'U'; LDU >= 1 otherwise.
V (output) COMPLEX array, dimension (LDV,M)
If JOBV = 'V', V contains the unitary matrix V.
If JOBV = 'N', V is not referenced.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P) if
JOBV = 'V'; LDV >= 1 otherwise.
Q (output) COMPLEX array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the unitary matrix Q.
If JOBQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N) if
JOBQ = 'Q'; LDQ >= 1 otherwise.
IWORK (workspace) INTEGER array, dimension (N)
RWORK (workspace) REAL array, dimension (2*N)
TAU (workspace) COMPLEX array, dimension (N)
WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The subroutine uses LAPACK subroutine CGEQPF for the QR factorization
with column pivoting to detect the effective numerical rank of the
a matrix. It may be replaced by a better rank determination strategy.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
static logical wantq, wantu, wantv;
extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *), cgerq2_(integer *,
integer *, complex *, integer *, complex *, complex *, integer *),
cung2r_(integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *), cunm2r_(char *, char *, integer
*, integer *, integer *, complex *, integer *, complex *, complex
*, integer *, complex *, integer *), cunmr2_(char
*, char *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *,
integer *, complex *, complex *, real *, integer *), clacpy_(char
*, integer *, integer *, complex *, integer *, complex *, integer
*), claset_(char *, integer *, integer *, complex *,
complex *, complex *, integer *), xerbla_(char *, integer
*), clapmt_(logical *, integer *, integer *, complex *,
integer *, integer *);
static logical forwrd;
#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 u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--iwork;
--rwork;
--tau;
--work;
/* Function Body */
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (wantv || lsame_(jobv, "N"))) {
*info = -2;
} else if (! (wantq || lsame_(jobq, "N"))) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -8;
} else if (*ldb < max(1,*p)) {
*info = -10;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -16;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -18;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 )
( 0 0 ) */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
cgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1],
info);
/* Update A := A*P */
clapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, i__)),
dabs(r__2)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
claset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv);
}
i__1 = min(*p,*n);
cung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
claset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
clapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l) {
/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
cgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
cunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, &
tau[1], &a[a_offset], lda, &work[1], info);
if (wantq) {
/* Update Q := Q*Z' */
cunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset],
ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
claset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb);
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *l;
for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L
A = ( A11 A12 ) M,
then the following does the complete QR decomposition of A11:
A11 = U*( 0 T12 )*P1'
( 0 0 ) */
i__1 = *n - *l;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L70: */
}
i__1 = *n - *l;
cgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[
1], info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(i__, i__)),
dabs(r__2)) > *tola) {
++(*k);
}
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, &
tau[1], &a_ref(1, *n - *l + 1), lda, &work[1], info);
if (wantu) {
/* Copy the details of U, and form U */
claset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
clacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1),
ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
cung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
}
if (wantq) {
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
clapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
}
/* Clean up A: set the strictly lower triangular part of
A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
cgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
if (wantq) {
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
i__1 = *n - *l;
cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset],
lda, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up A */
i__1 = *n - *l - *k;
claset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
cgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1],
info);
if (wantu) {
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
cunm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, *
n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[
1], info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of CGGSVP */
} /* cggsvp_ */
/* 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 cchkq3_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, real *thresh, complex *a, complex *copya, real *s, real *copys,
complex *tau, complex *work, real *rwork, integer *iwork, integer *
nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 M =\002,i5,\002, N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
real eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode;
extern doublereal cqpt01_(integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cqrt11_(integer *, integer *, complex *, integer *, complex *,
complex *, integer *), cqrt12_(integer *, integer *, complex *,
integer *, real *, complex *, integer *, real *);
integer mnmin;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
integer istep, nerrs, lwork;
extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
integer *, integer *, complex *, complex *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
*), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
xlaenv_(integer *, integer *);
real result[3];
/* Fortran I/O blocks */
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKQ3 tests CGEQP3. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX array, dimension (MMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) REAL array, dimension (4*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = slamch_("Epsilon");
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L70;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
claset_("Full", &m, &n, &c_b1, &c_b1, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &r__1, &c_b15, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Save A and its singular values and a copy of */
/* vector IWORK. */
clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
/* Workspace needed. */
lw = nb * (n + 1);
s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)6, (ftnlen)6);
cgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
work[1], &lw, &rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
work[1], &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "CGEQP3", (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
/* L60: */
}
L70:
;
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of CCHKQ3 */
return 0;
} /* cchkq3_ */
/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_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 routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
CHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* **
Initialize */
opst = 0.f;
/* **
Initialize Z, if necessary */
if (initz) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
q__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, q__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* **
Increment op count */
opst += (i2 - i1 + 2) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h___ref(
k - 1, k - 1)), dabs(r__2)) + ((r__3 = h__[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&h___ref(k, k)), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = clanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = h__[i__6]
.r, dabs(r__2))) * 1.5f;
w[i__3].r = r__3, w[i__3].i = 0.f;
/* L90: */
}
/* **
Increment op count */
opst += ns << 1;
/* ** */
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
clahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0.f, v[i__3].i = 0.f;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
ccopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -w[i__5].r, q__1.i = -w[i__5].i;
cgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &q__1, v, &c__1);
++nv;
/* **
Increment op count */
opst = opst + (nv << 3) * (*n + 1) + (nv + 1) * 6;
/* **
Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax_(&nv, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
i__3 = itemp - 1;
rtemp = (r__1 = v[i__3].r, dabs(r__1)) + (r__2 = r_imag(&v[itemp
- 1]), dabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0.f, v[i__5].i = 0.f;
/* L120: */
}
} else {
rtemp = dmax(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal_(&nv, &r__1, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
clarfg_(&nr, v, &v[1], &c__1, &tau);
/* **
Increment op count */
opst = opst + nr * 10 + 12;
/* ** */
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L140: */
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx_("Left", &nr, &i__3, v, &q__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
clarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
/* **
Increment op count
Computing MIN */
i__3 = nr, i__5 = i__ - k;
latime_1.ops += ((nr << 2) - 2 << 2) * (i2 - i1 + 2 + min(i__3,
i__5));
/* ** */
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
/* **
Increment op count */
latime_1.ops += ((nr << 2) - 2 << 2) * nh;
/* ** */
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
clahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CHSEQR */
} /* chseqr_ */
/* 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 cqlt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
real resid, anorm;
integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
integer *, complex *, 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 *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n */
/* matrix A, and partially tests CUNGQL which forms the m-by-m */
/* orthogonal matrix Q. */
/* CQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by CGEQLF. */
/* See CGEQLF for further details. */
/* Q (output) COMPLEX array, dimension (LDA,M) */
/* The m-by-m orthogonal matrix Q. */
/* L (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and R. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by CGEQLF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6);
cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
q_dim1 + 1], lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
lda, &q[(q_dim1 << 1) + 1], lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
clacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
n + 1 + l_dim1], lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
clacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
*n - *m + 1) * l_dim1 + 1], lda);
}
}
/* Compute L - Q'*A */
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT01 */
} /* cqlt01_ */
