/* Subroutine */ int sdrvge_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
real *s, real *work, real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, N =\002,i5,\002, type \002,i2,"
"\002, test(\002,i2,\002) =\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,"
"\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', TRANS='\002,"
"a1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
real r__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
char dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc;
extern /* Subroutine */ int sget01_(integer *, integer *, real *, integer
*, real *, integer *, integer *, real *, real *);
integer nimat;
real roldi;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *);
real anorm;
integer itran;
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *);
logical equil;
real roldo;
extern /* Subroutine */ int sget07_(char *, integer *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, real *, real *);
char trans[1];
integer izero, nerrs;
extern /* Subroutine */ int sgesv_(integer *, integer *, real *, integer *
, integer *, real *, integer *, integer *);
integer lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
real colcnd;
extern doublereal slamch_(char *);
real rcondc;
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
logical nofact;
integer iequed;
extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, char *);
real rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
real cndnum, anormi, rcondo, ainvnm;
extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *);
logical trfcon;
real anormo, rowcnd;
extern /* Subroutine */ int sgetrf_(integer *, integer *, real *, integer
*, integer *, integer *), sgetri_(integer *, real *, integer *,
integer *, real *, integer *, integer *), slacpy_(char *, integer
*, integer *, real *, integer *, real *, integer *),
slarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, integer *, integer *);
extern doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), slatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, real *, integer *, real *, integer *
), xlaenv_(integer *, integer *);
real result[7];
extern /* Subroutine */ int sgesvx_(char *, char *, integer *, integer *,
real *, integer *, real *, integer *, integer *, char *, real *,
real *, real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *, integer *);
real rpvgrw;
extern /* Subroutine */ int serrvx_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGE tests the driver routines SGESV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) REAL array, dimension (NMAX*NMAX) */
/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (2*NMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
/* Skip types 5, 6, or 7 if the matrix size is too small. */
zerot = imat >= 5 && imat <= 7;
if (zerot && n < imat - 4) {
goto L80;
}
/* Set up parameters with SLATB4 and generate a test matrix */
/* with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)6, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L80;
}
/* For types 5-7, zero one or more columns of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 5) {
izero = 1;
} else if (imat == 6) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 7) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L20: */
}
} else {
i__3 = n - izero + 1;
slaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
lda);
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
slacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L60;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (! nofact) {
/* Compute the condition number for comparison with */
/* the value returned by SGESVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
slacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
sgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
&rowcnd, &colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R"))
{
rowcnd = 0.f;
colcnd = 1.f;
} else if (lsame_(equed, "C")) {
rowcnd = 1.f;
colcnd = 0.f;
} else if (lsame_(equed, "B")) {
rowcnd = 0.f;
colcnd = 0.f;
}
/* Equilibrate the matrix. */
slaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
1], &rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the non-equilibrated */
/* system for use in SGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = slange_("1", &n, &n, &afac[1], &lda, &rwork[
1]);
anormi = slange_("I", &n, &n, &afac[1], &lda, &rwork[
1]);
/* Factor the matrix A. */
sgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
/* Form the inverse of A. */
slacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
lwork = *nmax * max(3,*nrhs);
sgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
&info);
/* Compute the 1-norm condition number of A. */
ainvnm = slange_("1", &n, &n, &a[1], &lda, &rwork[1]);
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Compute the infinity-norm condition number of A. */
ainvnm = slange_("I", &n, &n, &a[1], &lda, &rwork[1]);
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)6, (ftnlen)
6);
slarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact && itran == 1) {
/* --- Test SGESV --- */
/* Compute the LU factorization of the matrix and */
/* solve the system. */
slacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
lda);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "SGESV ", (ftnlen)6, (
ftnlen)6);
sgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
&lda, &info);
/* Check error code from SGESV . */
if (info != izero) {
alaerh_(path, "SGESV ", &info, &izero, " ", &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
}
/* Reconstruct matrix from factors and compute */
/* residual. */
sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
1], &lda);
sget02_("No transpose", &n, &n, nrhs, &a[1], &
lda, &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, "SGESV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += nt;
}
/* --- Test SGESVX --- */
if (! prefac) {
slaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
&lda);
}
slaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
slaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using SGESVX. */
s_copy(srnamc_1.srnamt, "SGESVX", (ftnlen)6, (ftnlen)
6);
sgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
&lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check the error code from SGESVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SGESVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
}
/* Compare WORK(1) from SGESVX with the computed */
/* reciprocal pivot growth factor RPVGRW */
if (info != 0) {
rpvgrw = slantr_("M", "U", "N", &info, &info, &
afac[1], &lda, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", &n, &info, &a[1], &lda,
&work[1]) / rpvgrw;
}
} else {
rpvgrw = slantr_("M", "U", "N", &n, &n, &afac[1],
&lda, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", &n, &n, &a[1], &lda, &
work[1]) / rpvgrw;
}
}
result[6] = (r__1 = rpvgrw - work[1], dabs(r__1)) /
dmax(work[1],rpvgrw) / slamch_("E")
;
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &rwork[(*nrhs << 1) + 1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
sget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
, &lda, &work[1], &lda, &rwork[(*nrhs <<
1) + 1], &result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
sget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from SGESVX with the computed value */
/* in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___61.ciunit = *nout;
s_wsfe(&io___61);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___62.ciunit = *nout;
s_wsfe(&io___62);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
}
/* L40: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___63.ciunit = *nout;
s_wsfe(&io___63);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___64.ciunit = *nout;
s_wsfe(&io___64);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___66.ciunit = *nout;
s_wsfe(&io___66);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__6, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[5], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___67.ciunit = *nout;
s_wsfe(&io___67);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___68.ciunit = *nout;
s_wsfe(&io___68);
do_fio(&c__1, "SGESVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* L50: */
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* L90: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVGE */
} /* sdrvge_ */
/* Subroutine */ int sdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, real *a, integer *lda, real *b, real *s, real *t, real *s2,
real *t2, real *q, integer *ldq, real *z__, real *alphr1, real *
alphi1, real *beta1, real *alphr2, real *alphi2, real *beta2, real *
vl, real *vr, real *work, integer *lwork, real *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 SDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 SDRVGG: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(\002 SDRVGG: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 SDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
"oblem driver\002)";
static char fmt_9994[] = "(\002 Matrix types (see SDRVGG for details):"
" \002)";
static char fmt_9993[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9992[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
" 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
"I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double r_sign(real *, real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
real ulp;
integer iadd, nmax;
real temp1, temp2;
logical badnn;
real dumma[4];
integer iinfo;
real rmagn[4];
extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *), sget52_(logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
real *), sgegv_(char *, char *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, integer *),
sget53_(real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *);
integer nmats, jsize, nerrs, jtype, ntest;
extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, integer *
, real *, integer *);
logical ilabad;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
real safmin;
integer ioldsd[4];
real safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
real ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGG checks the nonsymmetric generalized eigenvalue driver */
/* routines. */
/* T T T */
/* SGEGS factors A and B as Q S Z and Q T Z , where means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
/* eigenvalue problem */
/* det( A - w(j) B ) = 0 */
/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
/* problem */
/* det( m(j) A - B ) = 0 */
/* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), the matrix L whose columns contain the */
/* generalized left eigenvectors l, and the matrix R whose columns */
/* contain the generalized right eigenvectors r for the pair (A,B). */
/* When SDRVGG is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed and compared with the threshhold THRESH: */
/* Results from SGEGS: */
/* T */
/* (1) | A - Q S Z | / ( |A| n ulp ) */
/* T */
/* (2) | B - Q T Z | / ( |B| n ulp ) */
/* T */
/* (3) | I - QQ | / ( n ulp ) */
/* T */
/* (4) | I - ZZ | / ( n ulp ) */
/* (5) maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th eigenvalue. */
/* Results from SGEGV: */
/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* Test Matrices */
/* ---- -------- */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* SDRVGG does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, SDRVGG */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to SDRVGG to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* THRSHN (input) REAL */
/* Threshhold for reporting eigenvector normalization error. */
/* If the normalization of any eigenvector differs from 1 by */
/* more than THRSHN*ulp, then a special error message will be */
/* printed. (This is handled separately from the other tests, */
/* since only a compiler or programming error should cause an */
/* error message, at least if THRSHN is at least 5--10.) */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, T, S2, and T2. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) REAL array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by SGEGS. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) REAL array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by SGEGS. */
/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from A by SGEGV. This will be the */
/* Schur form of some matrix related to A, but will not, in */
/* general, be the same as S. */
/* T2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from B by SGEGV. This will be the */
/* Schur form of some matrix related to B, but will not, in */
/* general, be the same as T. */
/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by SGEGS. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q, Z, VL, and VR. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) REAL array of */
/* dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by SGEGS. */
/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
/* BETA1 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGS. */
/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* ALPHR2 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI2 (workspace) REAL array, dimension (max(NN)) */
/* BETA2 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGV. */
/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* VL (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block lower triangular) left eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* VR (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block upper triangular) right eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
/* "k" is the sum of the blocksize and number-of-shifts for */
/* SHGEQZ, and NB is the greatest of the blocksizes for */
/* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the */
/* number-of-shifts are retrieved through calls to ILAENV.) */
/* RESULT (output) REAL array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alphr1;
--alphi1;
--beta1;
--alphr2;
--alphi2;
--beta2;
--work;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number */
/* of shifts are monotone increasing functions of N. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "SORGQR",
" ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
ns = ilaenv_(&c__4, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = (nmax << 1) + max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L160;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 15; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B */
/* Description of control parameters: */
/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* IASIGN: 1 if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number, =2 if */
/* randomly chosen diagonal blocks are to be rotated */
/* to form 2x2 blocks. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
lda);
}
} else {
in = n;
}
slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a[iadd + iadd * a_dim1] = 1.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
lda);
}
} else {
in = n;
}
slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b42, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b[iadd + iadd * b_dim1] = 1.f;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = r_sign(&c_b42, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.f;
i__4 = n + 1 - jc;
slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = r_sign(&c_b42, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.f;
/* L50: */
}
q[n + n * q_dim1] = 1.f;
work[n] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 3] = r_sign(&c_b42, &r__1);
z__[n + n * z_dim1] = 1.f;
work[n * 2] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 4] = r_sign(&c_b42, &r__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * a[jr + jc * a_dim1];
b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * b[jr + jc * b_dim1];
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
/* Call SGEGS to compute H, T, Q, Z, alpha, and beta. */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
sgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "SGEGS", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 4;
/* Do tests 1--4 */
sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
;
sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
;
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
;
/* Do test 5: compare eigenvalues with diagonals. */
/* Also check Schur form of A. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi1[j] == 0.f) {
/* Computing MAX */
r__7 = safmin, r__8 = (r__2 = alphr1[j], dabs(r__2)),
r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j *
s_dim1], dabs(r__3));
/* Computing MAX */
r__9 = safmin, r__10 = (r__5 = beta1[j], dabs(r__5)),
r__9 = max(r__9,r__10), r__10 = (r__6 = t[j + j *
t_dim1], dabs(r__6));
temp2 = ((r__1 = alphr1[j] - s[j + j * s_dim1], dabs(r__1)
) / dmax(r__7,r__8) + (r__4 = beta1[j] - t[j + j *
t_dim1], dabs(r__4)) / dmax(r__9,r__10)) / ulp;
if (j < n) {
if (s[j + 1 + j * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (j > 1) {
if (s[j + (j - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
} else {
if (alphi1[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
} else if (i1 > 1) {
if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (! ilabad) {
sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
j], &temp2, &iinfo);
if (iinfo >= 3) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L120: */
}
result[5] = temp1;
/* Call SGEGV to compute S2, T2, VL, and VR, do tests. */
/* Eigenvalues and Eigenvectors */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
sgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
vr[vr_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 7;
/* Do Tests 6 and 7 */
sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Check form of Complex eigenvalues. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi2[j] > 0.f) {
if (j == n) {
ilabad = TRUE_;
} else if (alphi2[j + 1] >= 0.f) {
ilabad = TRUE_;
}
} else if (alphi2[j] < 0.f) {
if (j == 1) {
ilabad = TRUE_;
} else if (alphi2[j - 1] <= 0.f) {
ilabad = TRUE_;
}
}
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L130: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L140:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "SGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
} else {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
}
/* L150: */
}
L160:
;
}
/* L170: */
}
/* Summary */
alasvm_("SGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of SDRVGG */
} /* sdrvgg_ */
/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__,
real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
indx, integer *ctot, real *w, real *s, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
integer i__, j, n2, n12, ii, n23, iq2;
real temp;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *), scopy_(integer *, real *,
integer *, real *, integer *), slaed4_(integer *, integer *, real
*, real *, real *, real *, real *, integer *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAED3 finds the roots of the secular equation, as defined by the */
/* values in D, W, and RHO, between 1 and K. It makes the */
/* appropriate calls to SLAED4 and then updates the eigenvectors by */
/* multiplying the matrix of eigenvectors of the pair of eigensystems */
/* being combined by the matrix of eigenvectors of the K-by-K system */
/* which is solved here. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* K (input) INTEGER */
/* The number of terms in the rational function to be solved by */
/* SLAED4. K >= 0. */
/* N (input) INTEGER */
/* The number of rows and columns in the Q matrix. */
/* N >= K (deflation may result in N>K). */
/* N1 (input) INTEGER */
/* The location of the last eigenvalue in the leading submatrix. */
/* min(1,N) <= N1 <= N/2. */
/* D (output) REAL array, dimension (N) */
/* D(I) contains the updated eigenvalues for */
/* 1 <= I <= K. */
/* Q (output) REAL array, dimension (LDQ,N) */
/* Initially the first K columns are used as workspace. */
/* On output the columns 1 to K contain */
/* the updated eigenvectors. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* RHO (input) REAL */
/* The value of the parameter in the rank one update equation. */
/* RHO >= 0 required. */
/* DLAMDA (input/output) REAL array, dimension (K) */
/* The first K elements of this array contain the old roots */
/* of the deflated updating problem. These are the poles */
/* of the secular equation. May be changed on output by */
/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
/* Cray-2, or Cray C-90, as described above. */
/* Q2 (input) REAL array, dimension (LDQ2, N) */
/* The first K columns of this matrix contain the non-deflated */
/* eigenvectors for the split problem. */
/* INDX (input) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of the deflated */
/* Q matrix into three groups (see SLAED2). */
/* The rows of the eigenvectors found by SLAED4 must be likewise */
/* permuted before the matrix multiply can take place. */
/* CTOT (input) INTEGER array, dimension (4) */
/* A count of the total number of the various types of columns */
/* in Q, as described in INDX. The fourth column type is any */
/* column which has been deflated. */
/* W (input/output) REAL array, dimension (K) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating vector. Destroyed on */
/* output. */
/* S (workspace) REAL array, dimension (N1 + 1)*K */
/* Will contain the eigenvectors of the repaired matrix which */
/* will be multiplied by the previously accumulated eigenvectors */
/* to update the system. */
/* LDS (input) INTEGER */
/* The leading dimension of S. LDS >= max(1,K). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an eigenvalue did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--dlamda;
--q2;
--indx;
--ctot;
--w;
--s;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*n < *k) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DLAMDA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1) {
goto L110;
}
if (*k == 2) {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
w[1] = q[j * q_dim1 + 1];
w[2] = q[j * q_dim1 + 2];
ii = indx[1];
q[j * q_dim1 + 1] = w[ii];
ii = indx[2];
q[j * q_dim1 + 2] = w[ii];
/* L30: */
}
goto L110;
}
/* Compute updated W. */
scopy_(k, &w[1], &c__1, &s[1], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L40: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */
}
/* L60: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = sqrt(-w[i__]);
w[i__] = r_sign(&r__1, &s[i__]);
/* L70: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q[i__ + j * q_dim1];
/* L80: */
}
temp = snrm2_(k, &s[1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__];
q[i__ + j * q_dim1] = s[ii] / temp;
/* L90: */
}
/* L100: */
}
/* Compute the updated eigenvectors. */
L110:
n2 = *n - *n1;
n12 = ctot[1] + ctot[2];
n23 = ctot[2] + ctot[3];
slacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23);
iq2 = *n1 * n12 + 1;
if (n23 != 0) {
sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
c_b23, &q[*n1 + 1 + q_dim1], ldq);
} else {
slaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq);
}
slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
if (n12 != 0) {
sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
&q[q_offset], ldq);
} else {
slaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq);
}
L120:
return 0;
/* End of SLAED3 */
} /* slaed3_ */
doublereal sqrt11_(integer *m, integer *k, real *a, integer *lda, real *tau,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real ret_val;
/* Local variables */
integer j, info;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
char *, integer *, integer *, real *, real *, real *, integer *);
real rdummy[1];
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQRT11 computes the test ratio */
/* || Q'*Q - I || / (eps * m) */
/* where the orthogonal matrix Q is represented as a product of */
/* elementary transformations. Each transformation has the form */
/* H(k) = I - tau(k) v(k) v(k)' */
/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
/* in A(k+1:m,k). */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* K (input) INTEGER */
/* The number of columns of A whose subdiagonal entries */
/* contain information about orthogonal transformations. */
/* A (input) REAL array, dimension (LDA,K) */
/* The (possibly partial) output of a QR reduction routine. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* TAU (input) REAL array, dimension (K) */
/* The scaling factors tau for the elementary transformations as */
/* computed by the QR factorization routine. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= M*M + M. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.f;
/* Test for sufficient workspace */
if (*lwork < *m * *m + *m) {
xerbla_("SQRT11", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0) {
return ret_val;
}
slaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
/* Form Q */
sorm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
work[1], m, &work[*m * *m + 1], &info);
/* Form Q'*Q */
sorm2r_("Left", "Transpose", m, m, k, &a[a_offset], lda, &tau[1], &work[1]
, m, &work[*m * *m + 1], &info);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
work[(j - 1) * *m + j] += -1.f;
/* L10: */
}
ret_val = slange_("One-norm", m, m, &work[1], m, rdummy) / ((
real) (*m) * slamch_("Epsilon"));
return ret_val;
/* End of SQRT11 */
} /* sqrt11_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
*a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real f, g;
integer i__, m;
real s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2], ar[2],
sa, sb, li[16] /* was [4][4] */, ir[16] /* was [4][4]
*/, ss, ws, eps;
logical weak;
real ddum;
integer idum;
real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16]
/* was [4][4] */;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real scale, bqra21, brqa21;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real licop[16] /* was [4][4] */;
integer linfo;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real ircop[16] /* was [4][4] */, dnorm;
integer iwork[4];
extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *, real *), sgeqr2_(
integer *, integer *, real *, integer *, real *, real *, integer *
), sgerq2_(integer *, integer *, real *, integer *, real *, real *
, integer *), sorg2r_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *), sorgr2_(integer *, integer
*, integer *, real *, integer *, real *, real *, integer *),
sorm2r_(char *, char *, integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *);
real dscale;
extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *);
real thresh;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), slassq_(integer *, real *,
integer *, real *, real *);
real smlnum;
logical strong;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
/* (A, B) by an orthogonal equivalence transformation. */
/* (A, B) must be in generalized real Schur canonical form (as returned */
/* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
/* diagonal blocks. B is upper triangular. */
/* Optionally, the matrices Q and Z of generalized Schur vectors are */
/* updated. */
/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
/* Arguments */
/* ========= */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) REAL arrays, dimensions (LDA,N) */
/* On entry, the matrix A in the pair (A, B). */
/* On exit, the updated matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) REAL arrays, dimensions (LDB,N) */
/* On entry, the matrix B in the pair (A, B). */
/* On exit, the updated matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
/* On exit, the updated matrix Q. */
/* Not referenced if WANTQ = .FALSE.. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
/* On exit, the updated matrix Z. */
/* Not referenced if WANTZ = .FALSE.. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If WANTZ = .TRUE., LDZ >= N. */
/* J1 (input) INTEGER */
/* The index to the first block (A11, B11). 1 <= J1 <= N. */
/* N1 (input) INTEGER */
/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
/* N2 (input) INTEGER */
/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)). */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
/* INFO (output) INTEGER */
/* =0: Successful exit */
/* >0: If INFO = 1, the transformed matrix (A, B) would be */
/* too far from generalized Schur form; the blocks are */
/* not swapped and (A, B) and (Q, Z) are unchanged. */
/* The problem of swapping is too ill-conditioned. */
/* <0: If INFO = -16: LWORK is too small. Appropriate value */
/* for LWORK is returned in WORK(1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* In the current code both weak and strong stability tests are */
/* performed. The user can omit the strong stability test by changing */
/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
/* details. */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* ===================================================================== */
/* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */
/* loops. Sven Hammarling, 1/5/02. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
return 0;
}
if (*n1 > *n || *j1 + *n1 > *n) {
return 0;
}
m = *n1 + *n2;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
if (*lwork < max(i__1,i__2)) {
*info = -16;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
work[1] = (real) max(i__1,i__2);
return 0;
}
weak = FALSE_;
strong = FALSE_;
/* Make a local copy of selected block */
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
/* Compute threshold for testing acceptance of swapping. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
dscale = 0.f;
dsum = 1.f;
slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
dnorm = dscale * sqrt(dsum);
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
if (m == 2) {
/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
/* using Givens rotations and perform the swap tentatively. */
f = s[5] * t[0] - t[5] * s[0];
g = s[5] * t[4] - t[5] * s[4];
sb = dabs(t[5]);
sa = dabs(s[5]);
slartg_(&f, &g, &ir[4], ir, &ddum);
ir[1] = -ir[4];
ir[5] = ir[0];
srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
if (sa >= sb) {
slartg_(s, &s[1], li, &li[1], &ddum);
} else {
slartg_(t, &t[1], li, &li[1], &ddum);
}
srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
li[5] = li[0];
li[4] = -li[1];
/* Weak stability test: */
/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
ws = dabs(s[1]) + dabs(t[1]);
weak = ws <= thresh;
if (! weak) {
goto L70;
}
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__1 = *j1 + 1;
srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *j1 + 1;
srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
lda, li, &li[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
ldb, li, &li[1]);
/* Set N1-by-N2 (2,1) - blocks to ZERO. */
a[*j1 + 1 + *j1 * a_dim1] = 0.f;
b[*j1 + 1 + *j1 * b_dim1] = 0.f;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
1], &c__1, ir, &ir[1]);
}
if (*wantq) {
srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
&c__1, li, &li[1]);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
} else {
/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
/* and 2-by-2 blocks. */
/* Solve the generalized Sylvester equation */
/* S11 * R - L * S22 = SCALE * S12 */
/* T11 * R - L * T22 = SCALE * T12 */
/* for R and L. Solutions in LI and IR. */
slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
*n1 + 1 << 2) - 5], &c__4);
stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
dsum, &dscale, iwork, &idum, &linfo);
/* Compute orthogonal matrix QL: */
/* QL' * LI = [ TL ] */
/* [ 0 ] */
/* where */
/* LI = [ -L ] */
/* [ SCALE * identity(N2) ] */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
li[*n1 + i__ + (i__ << 2) - 5] = scale;
/* L10: */
}
sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Compute orthogonal matrix RQ: */
/* IR * RQ' = [ 0 TR], */
/* where IR = [ SCALE * identity(N1), R ] */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
ir[*n2 + i__ + (i__ << 2) - 5] = scale;
/* L20: */
}
sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Perform the swapping tentatively: */
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
s, &c__4);
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
t, &c__4);
slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
/* Triangularize the B-part by an RQ factorization. */
/* Apply transformation (from left) to A-part, giving S. */
sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
/* L30: */
}
brqa21 = dscale * sqrt(dsum);
/* Triangularize the B-part by a QR factorization. */
/* Apply transformation (from right) to A-part, giving S. */
sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
, info);
sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
1], info);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
dsum);
/* L40: */
}
bqra21 = dscale * sqrt(dsum);
/* Decide which method to use. */
/* Weak stability test: */
/* F-norm(S21) <= O(EPS * F-norm((S, T))) */
if (bqra21 <= brqa21 && bqra21 <= thresh) {
slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
} else if (brqa21 >= thresh) {
goto L70;
}
/* Set lower triangle of B-part to zero */
i__1 = m - 1;
i__2 = m - 1;
slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the */
/* transformations and set N1-by-N2 (2,1)-block to zero. */
slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
;
slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
;
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
/* Standardize existing 2-by-2 blocks. */
i__1 = m * m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L50: */
}
work[1] = 1.f;
t[0] = 1.f;
idum = *lwork - m * m - 2;
if (*n2 > 1) {
slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
ar, ai, be, &work[1], &work[2], t, &t[1]);
work[m + 1] = -work[2];
work[m + 2] = work[1];
t[*n2 + (*n2 << 2) - 5] = t[0];
t[4] = -t[1];
}
work[m * m] = 1.f;
t[m + (m << 2) - 5] = 1.f;
if (*n1 > 1) {
slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
(*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
&work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
work[m * m] = work[*n2 * m + *n2 + 1];
work[m * m - 1] = -work[*n2 * m + *n2 + 2];
t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
}
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
a_dim1], lda);
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
b_dim1], ldb);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
work[m * m + 1], &m);
slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
lda);
sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb);
sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
work[1], &m);
slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
/* Accumulate transformations into Q and Z if requested. */
if (*wantq) {
sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
&c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
}
if (*wantz) {
sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
ir, &c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__ = *j1 + m;
if (i__ <= *n) {
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
a_dim1], lda, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
lda);
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
b_dim1], ldb, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
ldb);
}
i__ = *j1 - 1;
if (i__ > 0) {
sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
lda);
sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
ldb);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
}
/* Exit with INFO = 1 if swap was rejected. */
L70:
*info = 1;
return 0;
/* End of STGEX2 */
} /* stgex2_ */
/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real *
l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
real *wgap, integer *iblock, integer *indexw, real *gers, real *z__,
integer *ldz, integer *isuppz, real *work, integer *iwork, integer *
info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
logical L__1;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer minwsize, i__, j, k, p, q, miniwsize, ii;
real gl;
integer im, in;
real gu, gap, eps, tau, tol, tmp;
integer zto;
real ztz;
integer iend, jblk;
real lgap;
integer done;
real rgap, left;
integer wend, iter;
real bstw;
integer itmp1, indld;
real fudge;
integer idone;
real sigma;
integer iinfo, iindr;
real resid;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical eskip;
real right;
integer nclus, zfrom;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real rqtol;
integer iindc1, iindc2;
extern /* Subroutine */ int slar1v_(integer *, integer *, integer *, real
*, real *, real *, real *, real *, real *, real *, real *,
logical *, integer *, real *, real *, integer *, integer *, real *
, real *, real *, real *);
logical stp2ii;
real lambda;
integer ibegin, indeig;
logical needbs;
integer indlld;
real sgndef, mingma;
extern doublereal slamch_(char *);
integer oldien, oldncl, wbegin;
real spdiam;
integer negcnt, oldcls;
real savgap;
integer ndepth;
real ssigma;
logical usedbs;
integer iindwk, offset;
real gaptol;
extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *,
integer *, real *, real *, integer *, real *, real *, real *,
real *, integer *, real *, real *, integer *, integer *), slarrf_(
integer *, real *, real *, real *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, real *, real *,
real *, real *, integer *);
integer newcls, oldfst, indwrk, windex, oldlst;
logical usedrq;
integer newfst, newftt, parity, windmn, isupmn, newlst, windpl, zusedl,
newsiz, zusedu, zusedw;
real bstres, nrminv;
logical tryrqc;
integer isupmx;
real rqcorr;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARRV computes the eigenvectors of the tridiagonal matrix */
/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
/* The input eigenvalues should have been computed by SLARRE. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* VL (input) REAL */
/* VU (input) REAL */
/* Lower and upper bounds of the interval that contains the desired */
/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
/* end of the extremal eigenvalues in the desired RANGE. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the N diagonal elements of the diagonal matrix D. */
/* On exit, D may be overwritten. */
/* L (input/output) REAL array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the unit */
/* bidiagonal matrix L are in elements 1 to N-1 of L */
/* (if the matrix is not splitted.) At the end of each block */
/* is stored the corresponding shift as given by SLARRE. */
/* On exit, L is overwritten. */
/* PIVMIN (in) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to */
/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
/* through ISPLIT( 2 ), etc. */
/* M (input) INTEGER */
/* The total number of input eigenvalues. 0 <= M <= N. */
/* DOL (input) INTEGER */
/* DOU (input) INTEGER */
/* If the user wants to compute only selected eigenvectors from all */
/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
/* Or else the setting DOL=1, DOU=M should be applied. */
/* Note that DOL and DOU refer to the order in which the eigenvalues */
/* are stored in W. */
/* If the user wants to compute only selected eigenpairs, then */
/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
/* computed eigenvectors. All other columns of Z are set to zero. */
/* MINRGP (input) REAL */
/* RTOL1 (input) REAL */
/* RTOL2 (input) REAL */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* W (input/output) REAL array, dimension (N) */
/* The first M elements of W contain the APPROXIMATE eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block ( The output array */
/* W from SLARRE is expected here ). Furthermore, they are with */
/* respect to the shift of the corresponding root representation */
/* for their block. On exit, W holds the eigenvalues of the */
/* UNshifted matrix. */
/* WERR (input/output) REAL array, dimension (N) */
/* The first M elements contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue in W */
/* WGAP (input/output) REAL array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* IBLOCK (input) INTEGER array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (input) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
/* GERS (input) REAL array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
/* be computed from the original UNshifted matrix. */
/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
/* If INFO = 0, the first M columns of Z contain the */
/* orthonormal eigenvectors of the matrix T */
/* corresponding to the input eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The I-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
/* ISUPPZ( 2*I ). */
/* WORK (workspace) REAL array, dimension (12*N) */
/* IWORK (workspace) INTEGER array, dimension (7*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in SLARRV. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in SLARRB when refining a child's eigenvalues. */
/* =-2: Problem in SLARRF when computing the RRR of a child. */
/* When a child is inside a tight cluster, it can be difficult */
/* to find an RRR. A partial remedy from the user's point of */
/* view is to make the parameter MINRGP smaller and recompile. */
/* However, as the orthogonality of the computed vectors is */
/* proportional to 1/MINRGP, the user should be aware that */
/* he might be trading in precision when he decreases MINRGP. */
/* =-3: Problem in SLARRB when refining a single eigenvalue */
/* after the Rayleigh correction was rejected. */
/* = 5: The Rayleigh Quotient Iteration failed to converge to */
/* full accuracy in MAXITR steps. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* .. */
/* The first N entries of WORK are reserved for the eigenvalues */
/* Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--werr;
--wgap;
--iblock;
--indexw;
--gers;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
indld = *n + 1;
indlld = (*n << 1) + 1;
indwrk = *n * 3 + 1;
minwsize = *n * 12;
i__1 = minwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L5: */
}
/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
/* factorization used to compute the FP vector */
iindr = 0;
/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
/* layer and the one above. */
iindc1 = *n;
iindc2 = *n << 1;
iindwk = *n * 3 + 1;
miniwsize = *n * 7;
i__1 = miniwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zusedl = 1;
if (*dol > 1) {
/* Set lower bound for use of Z */
zusedl = *dol - 1;
}
zusedu = *m;
if (*dou < *m) {
/* Set lower bound for use of Z */
zusedu = *dou + 1;
}
/* The width of the part of Z that is used */
zusedw = zusedu - zusedl + 1;
slaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
eps = slamch_("Precision");
rqtol = eps * 2.f;
/* Set expert flags for standard code. */
tryrqc = TRUE_;
if (*dol == 1 && *dou == *m) {
} else {
/* Only selected eigenpairs are computed. Since the other evalues */
/* are not refined by RQ iteration, bisection has to compute to full */
/* accuracy. */
*rtol1 = eps * 4.f;
*rtol2 = eps * 4.f;
}
/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
/* desired eigenvalues. The support of the nonzero eigenvector */
/* entries is contained in the interval IBEGIN:IEND. */
/* Remark that if k eigenpairs are desired, then the eigenvectors */
/* are stored in k contiguous columns of Z. */
/* DONE is the number of eigenvectors already computed */
done = 0;
ibegin = 1;
wbegin = 1;
i__1 = iblock[*m];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
sigma = l[iend];
/* Find the eigenvectors of the submatrix indexed IBEGIN */
/* through IEND. */
wend = wbegin - 1;
L15:
if (wend < *m) {
if (iblock[wend + 1] == jblk) {
++wend;
goto L15;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L170;
} else if (wend < *dol || wbegin > *dou) {
ibegin = iend + 1;
wbegin = wend + 1;
goto L170;
}
/* Find local spectral diameter of the block */
gl = gers[(ibegin << 1) - 1];
gu = gers[ibegin * 2];
i__2 = iend;
for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
/* Computing MIN */
r__1 = gers[(i__ << 1) - 1];
gl = dmin(r__1,gl);
/* Computing MAX */
r__1 = gers[i__ * 2];
gu = dmax(r__1,gu);
/* L20: */
}
spdiam = gu - gl;
/* OLDIEN is the last index of the previous block */
oldien = ibegin - 1;
/* Calculate the size of the current block */
in = iend - ibegin + 1;
/* The number of eigenvalues in the current block */
im = wend - wbegin + 1;
/* This is for a 1x1 block */
if (ibegin == iend) {
++done;
z__[ibegin + wbegin * z_dim1] = 1.f;
isuppz[(wbegin << 1) - 1] = ibegin;
isuppz[wbegin * 2] = ibegin;
w[wbegin] += sigma;
work[wbegin] = w[wbegin];
ibegin = iend + 1;
++wbegin;
goto L170;
}
/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
/* Note that these can be approximations, in this case, the corresp. */
/* entries of WERR give the size of the uncertainty interval. */
/* The eigenvalue approximations will be refined when necessary as */
/* high relative accuracy is required for the computation of the */
/* corresponding eigenvectors. */
scopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
/* We store in W the eigenvalue approximations w.r.t. the original */
/* matrix T. */
i__2 = im;
for (i__ = 1; i__ <= i__2; ++i__) {
w[wbegin + i__ - 1] += sigma;
/* L30: */
}
/* NDEPTH is the current depth of the representation tree */
ndepth = 0;
/* PARITY is either 1 or 0 */
parity = 1;
/* NCLUS is the number of clusters for the next level of the */
/* representation tree, we start with NCLUS = 1 for the root */
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = im;
/* IDONE is the number of eigenvectors already computed in the current */
/* block */
idone = 0;
/* loop while( IDONE.LT.IM ) */
/* generate the representation tree for the current block and */
/* compute the eigenvectors */
L40:
if (idone < im) {
/* This is a crude protection against infinitely deep trees */
if (ndepth > *m) {
*info = -2;
return 0;
}
/* breadth first processing of the current level of the representation */
/* tree: OLDNCL = number of clusters on current level */
oldncl = nclus;
/* reset NCLUS to count the number of child clusters */
nclus = 0;
parity = 1 - parity;
if (parity == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* Process the clusters on the current level */
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
j = oldcls + (i__ << 1);
/* OLDFST, OLDLST = first, last index of current cluster. */
/* cluster indices start with 1 and are relative */
/* to WBEGIN when accessing W, WGAP, WERR, Z */
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
/* Retrieve relatively robust representation (RRR) of cluster */
/* that has been computed at the previous level */
/* The RRR is stored in Z and overwritten once the eigenvectors */
/* have been computed or when the cluster is refined */
if (*dol == 1 && *dou == *m) {
/* Get representation from location of the leftmost evalue */
/* of the cluster */
j = wbegin + oldfst - 1;
} else {
if (wbegin + oldfst - 1 < *dol) {
/* Get representation from the left end of Z array */
j = *dol - 1;
} else if (wbegin + oldfst - 1 > *dou) {
/* Get representation from the right end of Z array */
j = *dou;
} else {
j = wbegin + oldfst - 1;
}
}
scopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
, &c__1);
i__3 = in - 1;
scopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
ibegin], &c__1);
sigma = z__[iend + (j + 1) * z_dim1];
/* Set the corresponding entries in Z to zero */
slaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
* z_dim1], ldz);
}
/* Compute DL and DLL of current RRR */
i__3 = iend - 1;
for (j = ibegin; j <= i__3; ++j) {
tmp = d__[j] * l[j];
work[indld - 1 + j] = tmp;
work[indlld - 1 + j] = tmp * l[j];
/* L50: */
}
if (ndepth > 0) {
/* P and Q are index of the first and last eigenvalue to compute */
/* within the current block */
p = indexw[wbegin - 1 + oldfst];
q = indexw[wbegin - 1 + oldlst];
/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
/* thru' Q-OFFSET elements of these arrays are to be used. */
/* OFFSET = P-OLDFST */
offset = indexw[wbegin] - 1;
/* perform limited bisection (if necessary) to get approximate */
/* eigenvalues to the precision needed. */
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
&q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
wbegin], &werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &in, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* We also recompute the extremal gaps. W holds all eigenvalues */
/* of the unshifted matrix and must be used for computation */
/* of WGAP, the entries of WORK might stem from RRRs with */
/* different shifts. The gaps from WBEGIN-1+OLDFST to */
/* WBEGIN-1+OLDLST are correctly computed in SLARRB. */
/* However, we only allow the gaps to become greater since */
/* this is what should happen when we decrease WERR */
if (oldfst > 1) {
/* Computing MAX */
r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin +
oldfst - 1] - werr[wbegin + oldfst - 1] - w[
wbegin + oldfst - 2] - werr[wbegin + oldfst -
2];
wgap[wbegin + oldfst - 2] = dmax(r__1,r__2);
}
if (wbegin + oldlst - 1 < wend) {
/* Computing MAX */
r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin +
oldlst] - werr[wbegin + oldlst] - w[wbegin +
oldlst - 1] - werr[wbegin + oldlst - 1];
wgap[wbegin + oldlst - 1] = dmax(r__1,r__2);
}
/* Each time the eigenvalues in WORK get refined, we store */
/* the newly found approximation with all shifts applied in W */
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
/* L53: */
}
}
/* Process the current node. */
newfst = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
if (j == oldlst) {
/* we are at the right end of the cluster, this is also the */
/* boundary of the child cluster */
newlst = j;
} else if (wgap[wbegin + j - 1] >= *minrgp * (r__1 = work[
wbegin + j - 1], dabs(r__1))) {
/* the right relative gap is big enough, the child cluster */
/* (NEWFST,..,NEWLST) is well separated from the following */
newlst = j;
} else {
/* inside a child cluster, the relative gap is not */
/* big enough. */
goto L140;
}
/* Compute size of child cluster found */
newsiz = newlst - newfst + 1;
/* NEWFTT is the place in Z where the new RRR or the computed */
/* eigenvector is to be stored */
if (*dol == 1 && *dou == *m) {
/* Store representation at location of the leftmost evalue */
/* of the cluster */
newftt = wbegin + newfst - 1;
} else {
if (wbegin + newfst - 1 < *dol) {
/* Store representation at the left end of Z array */
newftt = *dol - 1;
} else if (wbegin + newfst - 1 > *dou) {
/* Store representation at the right end of Z array */
newftt = *dou;
} else {
newftt = wbegin + newfst - 1;
}
}
if (newsiz > 1) {
/* Current child is not a singleton but a cluster. */
/* Compute and store new representation of child. */
/* Compute left and right cluster gap. */
/* LGAP and RGAP are not computed from WORK because */
/* the eigenvalue approximations may stem from RRRs */
/* different shifts. However, W hold all eigenvalues */
/* of the unshifted matrix. Still, the entries in WGAP */
/* have to be computed from WORK since the entries */
/* in W might be of the same order so that gaps are not */
/* exhibited correctly for very close eigenvalues. */
if (newfst == 1) {
/* Computing MAX */
r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl;
lgap = dmax(r__1,r__2);
} else {
lgap = wgap[wbegin + newfst - 2];
}
rgap = wgap[wbegin + newlst - 1];
/* Compute left- and rightmost eigenvalue of child */
/* to high precision in order to shift as close */
/* as possible and obtain as large relative gaps */
/* as possible */
for (k = 1; k <= 2; ++k) {
if (k == 1) {
p = indexw[wbegin - 1 + newfst];
} else {
p = indexw[wbegin - 1 + newlst];
}
offset = indexw[wbegin] - 1;
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &p, &p, &rqtol, &rqtol, &offset, &
work[wbegin], &wgap[wbegin], &werr[wbegin]
, &work[indwrk], &iwork[iindwk], pivmin, &
spdiam, &in, &iinfo);
/* L55: */
}
if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
> *dou) {
/* if the cluster contains no desired eigenvalues */
/* skip the computation of that branch of the rep. tree */
/* We could skip before the refinement of the extremal */
/* eigenvalues of the child, but then the representation */
/* tree could be different from the one when nothing is */
/* skipped. For this reason we skip at this place. */
idone = idone + newlst - newfst + 1;
goto L139;
}
/* Compute RRR of child cluster. */
/* Note that the new RRR is stored in Z */
/* SLARRF needs LWORK = 2*N */
slarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
ibegin - 1], &newfst, &newlst, &work[wbegin],
&wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
&rgap, pivmin, &tau, &z__[ibegin + newftt *
z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
&work[indwrk], &iinfo);
if (iinfo == 0) {
/* a new RRR for the cluster was found by SLARRF */
/* update shift and store it */
ssigma = sigma + tau;
z__[iend + (newftt + 1) * z_dim1] = ssigma;
/* WORK() are the midpoints and WERR() the semi-width */
/* Note that the entries in W are unchanged. */
i__4 = newlst;
for (k = newfst; k <= i__4; ++k) {
fudge = eps * 3.f * (r__1 = work[wbegin + k -
1], dabs(r__1));
work[wbegin + k - 1] -= tau;
fudge += eps * 4.f * (r__1 = work[wbegin + k
- 1], dabs(r__1));
/* Fudge errors */
werr[wbegin + k - 1] += fudge;
/* Gaps are not fudged. Provided that WERR is small */
/* when eigenvalues are close, a zero gap indicates */
/* that a new representation is needed for resolving */
/* the cluster. A fudge could lead to a wrong decision */
/* of judging eigenvalues 'separated' which in */
/* reality are not. This could have a negative impact */
/* on the orthogonality of the computed eigenvectors. */
/* L116: */
}
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfst;
iwork[k] = newlst;
} else {
*info = -2;
return 0;
}
} else {
/* Compute eigenvector of singleton */
iter = 0;
tol = log((real) in) * 4.f * eps;
k = newfst;
windex = wbegin + k - 1;
/* Computing MAX */
i__4 = windex - 1;
windmn = max(i__4,1);
/* Computing MIN */
i__4 = windex + 1;
windpl = min(i__4,*m);
lambda = work[windex];
++done;
/* Check if eigenvector computation is to be skipped */
if (windex < *dol || windex > *dou) {
eskip = TRUE_;
goto L125;
} else {
eskip = FALSE_;
}
left = work[windex] - werr[windex];
right = work[windex] + werr[windex];
indeig = indexw[windex];
/* Note that since we compute the eigenpairs for a child, */
/* all eigenvalue approximations are w.r.t the same shift. */
/* In this case, the entries in WORK should be used for */
/* computing the gaps since they exhibit even very small */
/* differences in the eigenvalues, as opposed to the */
/* entries in W which might "look" the same. */
if (k == 1) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VL, the formula */
/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
/* can lead to an overestimation of the left gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small left gap. */
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
lgap = eps * dmax(r__1,r__2);
} else {
lgap = wgap[windmn];
}
if (k == im) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VU, the formula */
/* can lead to an overestimation of the right gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small right gap. */
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
rgap = eps * dmax(r__1,r__2);
} else {
rgap = wgap[windex];
}
gap = dmin(lgap,rgap);
if (k == 1 || k == im) {
/* The eigenvector support can become wrong */
/* because significant entries could be cut off due to a */
/* large GAPTOL parameter in LAR1V. Prevent this. */
gaptol = 0.f;
} else {
gaptol = gap * eps;
}
isupmn = in;
isupmx = 1;
/* Update WGAP so that it holds the minimum gap */
/* to the left or the right. This is crucial in the */
/* case where bisection is used to ensure that the */
/* eigenvalue is refined up to the required precision. */
/* The correct value is restored afterwards. */
savgap = wgap[windex];
wgap[windex] = gap;
/* We want to use the Rayleigh Quotient Correction */
/* as often as possible since it converges quadratically */
/* when we are close enough to the desired eigenvalue. */
/* However, the Rayleigh Quotient can have the wrong sign */
/* and lead us away from the desired eigenvalue. In this */
/* case, the best we can do is to use bisection. */
usedbs = FALSE_;
usedrq = FALSE_;
/* Bisection is initially turned off unless it is forced */
needbs = ! tryrqc;
L120:
/* Check if bisection should be used to refine eigenvalue */
if (needbs) {
/* Take the bisection as new iterate */
usedbs = TRUE_;
itmp1 = iwork[iindr + windex];
offset = indexw[wbegin] - 1;
r__1 = eps * 2.f;
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &indeig, &indeig, &c_b5, &r__1, &
offset, &work[wbegin], &wgap[wbegin], &
werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &itmp1, &iinfo);
if (iinfo != 0) {
*info = -3;
return 0;
}
lambda = work[windex];
/* Reset twist index from inaccurate LAMBDA to */
/* force computation of true MINGMA */
iwork[iindr + windex] = 0;
}
/* Given LAMBDA, compute the eigenvector. */
L__1 = ! usedbs;
slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
ibegin], &work[indld + ibegin - 1], &work[
indlld + ibegin - 1], pivmin, &gaptol, &z__[
ibegin + windex * z_dim1], &L__1, &negcnt, &
ztz, &mingma, &iwork[iindr + windex], &isuppz[
(windex << 1) - 1], &nrminv, &resid, &rqcorr,
&work[indwrk]);
if (iter == 0) {
bstres = resid;
bstw = lambda;
} else if (resid < bstres) {
bstres = resid;
bstw = lambda;
}
/* Computing MIN */
i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
isupmn = min(i__4,i__5);
/* Computing MAX */
i__4 = isupmx, i__5 = isuppz[windex * 2];
isupmx = max(i__4,i__5);
++iter;
/* sin alpha <= |resid|/gap */
/* Note that both the residual and the gap are */
/* proportional to the matrix, so ||T|| doesn't play */
/* a role in the quotient */
/* Convergence test for Rayleigh-Quotient iteration */
/* (omitted when Bisection has been used) */
if (resid > tol * gap && dabs(rqcorr) > rqtol * dabs(
lambda) && ! usedbs) {
/* We need to check that the RQCORR update doesn't */
/* move the eigenvalue away from the desired one and */
/* towards a neighbor. -> protection with bisection */
if (indeig <= negcnt) {
/* The wanted eigenvalue lies to the left */
sgndef = -1.f;
} else {
/* The wanted eigenvalue lies to the right */
sgndef = 1.f;
}
/* We only use the RQCORR if it improves the */
/* the iterate reasonably. */
if (rqcorr * sgndef >= 0.f && lambda + rqcorr <=
right && lambda + rqcorr >= left) {
usedrq = TRUE_;
/* Store new midpoint of bisection interval in WORK */
if (sgndef == 1.f) {
/* The current LAMBDA is on the left of the true */
/* eigenvalue */
left = lambda;
/* We prefer to assume that the error estimate */
/* is correct. We could make the interval not */
/* as a bracket but to be modified if the RQCORR */
/* chooses to. In this case, the RIGHT side should */
/* be modified as follows: */
/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
} else {
/* The current LAMBDA is on the right of the true */
/* eigenvalue */
right = lambda;
/* See comment about assuming the error estimate is */
/* correct above. */
/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
}
work[windex] = (right + left) * .5f;
/* Take RQCORR since it has the correct sign and */
/* improves the iterate reasonably */
lambda += rqcorr;
/* Update width of error interval */
werr[windex] = (right - left) * .5f;
} else {
needbs = TRUE_;
}
if (right - left < rqtol * dabs(lambda)) {
/* The eigenvalue is computed to bisection accuracy */
/* compute eigenvector and stop */
usedbs = TRUE_;
goto L120;
} else if (iter < 10) {
goto L120;
} else if (iter == 10) {
needbs = TRUE_;
goto L120;
} else {
*info = 5;
return 0;
}
} else {
stp2ii = FALSE_;
if (usedrq && usedbs && bstres <= resid) {
lambda = bstw;
stp2ii = TRUE_;
}
if (stp2ii) {
/* improve error angle by second step */
L__1 = ! usedbs;
slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
, &l[ibegin], &work[indld + ibegin -
1], &work[indlld + ibegin - 1],
pivmin, &gaptol, &z__[ibegin + windex
* z_dim1], &L__1, &negcnt, &ztz, &
mingma, &iwork[iindr + windex], &
isuppz[(windex << 1) - 1], &nrminv, &
resid, &rqcorr, &work[indwrk]);
}
work[windex] = lambda;
}
/* Compute FP-vector support w.r.t. whole matrix */
isuppz[(windex << 1) - 1] += oldien;
isuppz[windex * 2] += oldien;
zfrom = isuppz[(windex << 1) - 1];
zto = isuppz[windex * 2];
isupmn += oldien;
isupmx += oldien;
/* Ensure vector is ok if support in the RQI has changed */
if (isupmn < zfrom) {
i__4 = zfrom - 1;
for (ii = isupmn; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.f;
/* L122: */
}
}
if (isupmx > zto) {
i__4 = isupmx;
for (ii = zto + 1; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.f;
/* L123: */
}
}
i__4 = zto - zfrom + 1;
sscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
&c__1);
L125:
/* Update W */
w[windex] = lambda + sigma;
/* Recompute the gaps on the left and right */
/* But only allow them to become larger and not */
/* smaller (which can only happen through "bad" */
/* cancellation and doesn't reflect the theory */
/* where the initial gaps are underestimated due */
/* to WERR being too crude.) */
if (! eskip) {
if (k > 1) {
/* Computing MAX */
r__1 = wgap[windmn], r__2 = w[windex] - werr[
windex] - w[windmn] - werr[windmn];
wgap[windmn] = dmax(r__1,r__2);
}
if (windex < wend) {
/* Computing MAX */
r__1 = savgap, r__2 = w[windpl] - werr[windpl]
- w[windex] - werr[windex];
wgap[windex] = dmax(r__1,r__2);
}
}
++idone;
}
/* here ends the code for the current child */
L139:
/* Proceed to any remaining child nodes */
newfst = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* End of SLARRV */
} /* slarrv_ */
/* Subroutine */ int sgqrts_(integer *n, integer *m, integer *p, real *a,
real *af, real *q, real *r__, integer *lda, real *taua, real *b, real
*bf, real *z__, real *t, real *bwk, integer *ldb, real *taub, real *
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;
/* Local variables */
static integer info;
static real unfl, resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real anorm, bnorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sggqrf_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, real *, real *, integer *
, integer *), slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), sorgrq_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
static real ulp;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
#define bf_ref(a_1,a_2) bf[(a_2)*bf_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGQRTS tests SGGQRF, which computes the GQR factorization of an
N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z.
Arguments
=========
N (input) INTEGER
The number of rows of the matrices A and B. N >= 0.
M (input) INTEGER
The number of columns of the matrix A. M >= 0.
P (input) INTEGER
The number of columns of the matrix B. P >= 0.
A (input) REAL array, dimension (LDA,M)
The N-by-M matrix A.
AF (output) REAL array, dimension (LDA,N)
Details of the GQR factorization of A and B, as returned
by SGGQRF, see SGGQRF for further details.
Q (output) REAL array, dimension (LDA,N)
The M-by-M orthogonal matrix Q.
R (workspace) REAL 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) REAL array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by SGGQRF.
B (input) REAL array, dimension (LDB,P)
On entry, the N-by-P matrix A.
BF (output) REAL array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by SGGQRF, see SGGQRF for further details.
Z (output) REAL array, dimension (LDB,P)
The P-by-P orthogonal matrix Z.
T (workspace) REAL array, dimension (LDB,max(P,N))
BWK (workspace) REAL array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) REAL array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by SGGRQF.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK, LWORK >= max(N,M,P)**2.
RWORK (workspace) REAL array, dimension (max(N,M,P))
RESULT (output) REAL array, dimension (4)
The test ratios:
RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
RESULT(3) = norm( I - Q'*Q ) / ( M*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. */
slacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
slacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = slange_("1", n, m, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = slange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
sggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
slaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
i__1 = *n - 1;
slacpy_("Lower", &i__1, m, &af_ref(2, 1), lda, &q_ref(2, 1), lda);
i__1 = min(*n,*m);
sorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
slaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
if (*n <= *p) {
if (*n > 0 && *n < *p) {
i__1 = *p - *n;
slacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z___ref(*p - *n +
1, 1), ldb);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
slacpy_("Lower", &i__1, &i__2, &bf_ref(2, *p - *n + 1), ldb, &
z___ref(*p - *n + 2, *p - *n + 1), ldb);
}
} else {
if (*p > 1) {
i__1 = *p - 1;
i__2 = *p - 1;
slacpy_("Lower", &i__1, &i__2, &bf_ref(*n - *p + 2, 1), ldb, &
z___ref(2, 1), ldb);
}
}
i__1 = min(*n,*p);
sorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
slaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda);
slacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
/* Copy T */
slaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb);
if (*n <= *p) {
slacpy_("Upper", n, n, &bf_ref(1, *p - *n + 1), ldb, &t_ref(1, *p - *
n + 1), ldb);
} else {
i__1 = *n - *p;
slacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
slacpy_("Upper", p, p, &bf_ref(*n - *p + 1, 1), ldb, &t_ref(*n - *p +
1, 1), ldb);
}
/* Compute R - Q'*A */
sgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, &
a[a_offset], lda, &c_b31, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = slange_("1", n, m, &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*Z - Q'*B */
sgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb,
&z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
sgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, &
b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb);
/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = slange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - Q'*Q */
slaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
ssyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (real) max(1,*n) / ulp;
/* Compute I - Z'*Z */
slaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
ssyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = slansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
return 0;
/* End of SGQRTS */
} /* sgqrts_ */
/* Subroutine */ int ssapps_(integer *n, integer *kev, integer *np, real *
shift, real *v, integer *ldv, real *h__, integer *ldh, real *resid,
real *q, integer *ldq, real *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
/* Local variables */
static real c__, f, g;
static integer i__, j;
static real r__, s, a1, a2, a3, a4, t0, t1;
static integer jj;
static real big;
static integer iend, itop;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *, ftnlen), scopy_(
integer *, real *, integer *, real *, integer *), saxpy_(integer *
, real *, real *, integer *, real *, integer *), ivout_(integer *,
integer *, integer *, integer *, char *, ftnlen), svout_(integer
*, integer *, real *, integer *, char *, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int arscnd_(real *);
static real epsmch;
static integer istart, kplusp, msglvl;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slartg_(real *, real *,
real *, real *, real *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--shift;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
epsmch = slamch_("Epsilon-Machine", (ftnlen)15);
first = FALSE_;
}
itop = 1;
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
arscnd_(&t0);
msglvl = debug_1.msapps;
kplusp = *kev + *np;
/* %----------------------------------------------% */
/* | Initialize Q to the identity matrix of order | */
/* | kplusp used to accumulate the rotations. | */
/* %----------------------------------------------% */
slaset_("All", &kplusp, &kplusp, &c_b4, &c_b5, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------------------% */
/* | Apply the np shifts implicitly. Apply each shift to the | */
/* | whole matrix and not just to the submatrix from which it | */
/* | comes. | */
/* %----------------------------------------------------------% */
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
istart = itop;
/* %----------------------------------------------------------% */
/* | Check for splitting and deflation. Currently we consider | */
/* | an off-diagonal element h(i+1,1) negligible if | */
/* | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | */
/* | for i=1:KEV+NP-1. | */
/* | If above condition tests true then we set h(i+1,1) = 0. | */
/* | Note that h(1:KEV+NP,1) are assumed to be non negative. | */
/* %----------------------------------------------------------% */
L20:
/* %------------------------------------------------% */
/* | The following loop exits early if we encounter | */
/* | a negligible off diagonal element. | */
/* %------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[
i__ + 1 + (h_dim1 << 1)], dabs(r__2));
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit,
"_sapps: deflation at row/column no.", (ftnlen)35)
;
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit,
"_sapps: occured before shift number.", (ftnlen)
36);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], &
debug_1.ndigit, "_sapps: the corresponding off d"
"iagonal element", (ftnlen)46);
}
h__[i__ + 1 + h_dim1] = 0.f;
iend = i__;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (istart < iend) {
/* %--------------------------------------------------------% */
/* | Construct the plane rotation G'(istart,istart+1,theta) | */
/* | that attempts to drive h(istart+1,1) to zero. | */
/* %--------------------------------------------------------% */
f = h__[istart + (h_dim1 << 1)] - shift[jj];
g = h__[istart + 1 + h_dim1];
slartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G' * H * G, where G = G(istart,istart+1,theta). | */
/* | This will create a "bulge". | */
/* %-------------------------------------------------------% */
a1 = c__ * h__[istart + (h_dim1 << 1)] + s * h__[istart + 1 +
h_dim1];
a2 = c__ * h__[istart + 1 + h_dim1] + s * h__[istart + 1 + (
h_dim1 << 1)];
a4 = c__ * h__[istart + 1 + (h_dim1 << 1)] - s * h__[istart + 1 +
h_dim1];
a3 = c__ * h__[istart + 1 + h_dim1] - s * h__[istart + (h_dim1 <<
1)];
h__[istart + (h_dim1 << 1)] = c__ * a1 + s * a2;
h__[istart + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
h__[istart + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__3 = istart + jj;
i__2 = min(i__3,kplusp);
for (j = 1; j <= i__2; ++j) {
a1 = c__ * q[j + istart * q_dim1] + s * q[j + (istart + 1) *
q_dim1];
q[j + (istart + 1) * q_dim1] = -s * q[j + istart * q_dim1] +
c__ * q[j + (istart + 1) * q_dim1];
q[j + istart * q_dim1] = a1;
/* L60: */
}
/* %----------------------------------------------% */
/* | The following loop chases the bulge created. | */
/* | Note that the previous rotation may also be | */
/* | done within the following loop. But it is | */
/* | kept separate to make the distinction among | */
/* | the bulge chasing sweeps and the first plane | */
/* | rotation designed to drive h(istart+1,1) to | */
/* | zero. | */
/* %----------------------------------------------% */
i__2 = iend - 1;
for (i__ = istart + 1; i__ <= i__2; ++i__) {
/* %----------------------------------------------% */
/* | Construct the plane rotation G'(i,i+1,theta) | */
/* | that zeros the i-th bulge that was created | */
/* | by G(i-1,i,theta). g represents the bulge. | */
/* %----------------------------------------------% */
f = h__[i__ + h_dim1];
g = s * h__[i__ + 1 + h_dim1];
/* %----------------------------------% */
/* | Final update with G(i-1,i,theta) | */
/* %----------------------------------% */
h__[i__ + 1 + h_dim1] = c__ * h__[i__ + 1 + h_dim1];
slartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
if (r__ < 0.f) {
r__ = -r__;
c__ = -c__;
s = -s;
}
/* %--------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G * H * G', where G = G(i,i+1,theta) | */
/* %--------------------------------------------% */
h__[i__ + h_dim1] = r__;
a1 = c__ * h__[i__ + (h_dim1 << 1)] + s * h__[i__ + 1 +
h_dim1];
a2 = c__ * h__[i__ + 1 + h_dim1] + s * h__[i__ + 1 + (h_dim1
<< 1)];
a3 = c__ * h__[i__ + 1 + h_dim1] - s * h__[i__ + (h_dim1 << 1)
];
a4 = c__ * h__[i__ + 1 + (h_dim1 << 1)] - s * h__[i__ + 1 +
h_dim1];
h__[i__ + (h_dim1 << 1)] = c__ * a1 + s * a2;
h__[i__ + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
h__[i__ + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
a1 = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = a1;
/* L50: */
}
/* L70: */
}
}
/* %--------------------------% */
/* | Update the block pointer | */
/* %--------------------------% */
istart = iend + 1;
/* %------------------------------------------% */
/* | Make sure that h(iend,1) is non-negative | */
/* | If not then set h(iend,1) <-- -h(iend,1) | */
/* | and negate the last column of Q. | */
/* | We have effectively carried out a | */
/* | similarity on transformation H | */
/* %------------------------------------------% */
if (h__[iend + h_dim1] < 0.f) {
h__[iend + h_dim1] = -h__[iend + h_dim1];
sscal_(&kplusp, &c_b20, &q[iend * q_dim1 + 1], &c__1);
}
/* %--------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any | */
/* %--------------------------------------------------------% */
if (iend < kplusp) {
goto L20;
}
/* %-----------------------------------------------------% */
/* | Check if we can increase the the start of the block | */
/* %-----------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = itop; i__ <= i__2; ++i__) {
if (h__[i__ + 1 + h_dim1] > 0.f) {
goto L90;
}
++itop;
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the jj-th shift | */
/* %-----------------------------------% */
L90:
;
}
/* %------------------------------------------% */
/* | All shifts have been applied. Check for | */
/* | more possible deflation that might occur | */
/* | after the last shift is applied. | */
/* %------------------------------------------% */
i__1 = kplusp - 1;
for (i__ = itop; i__ <= i__1; ++i__) {
big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[i__
+ 1 + (h_dim1 << 1)], dabs(r__2));
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit, "_sapp"
"s: deflation at row/column no.", (ftnlen)35);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], &
debug_1.ndigit, "_sapps: the corresponding off diago"
"nal element", (ftnlen)46);
}
h__[i__ + 1 + h_dim1] = 0.f;
}
/* L100: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is not necessary if h(kev+1,1) = 0. | */
/* %-------------------------------------------------% */
if (h__[*kev + 1 + h_dim1] > 0.f) {
sgemv_("N", n, &kplusp, &c_b5, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %-------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage that Q is an upper triangular matrix | */
/* | with lower bandwidth np. | */
/* | Place results in v(:,kplusp-kev:kplusp) temporarily. | */
/* %-------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
sgemv_("N", n, &i__2, &c_b5, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[1], &c__1, (ftnlen)1);
scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L130: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
slacpy_("All", n, kev, &v[(*np + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv,
(ftnlen)3);
/* %--------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the | */
/* | appropriate place if h(kev+1,1) .ne. zero. | */
/* %--------------------------------------------% */
if (h__[*kev + 1 + h_dim1] > 0.f) {
scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kev+p}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + h_dim1] > 0.f) {
saxpy_(n, &h__[*kev + 1 + h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1,
&resid[1], &c__1);
}
if (msglvl > 1) {
svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_sapps: sigmak of the updated residual vect"
"or", (ftnlen)45);
svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + h_dim1], &
debug_1.ndigit, "_sapps: betak of the updated residual vector"
, (ftnlen)44);
svout_(&debug_1.logfil, kev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit,
"_sapps: updated main diagonal of H for next iteration", (
ftnlen)53);
if (*kev > 1) {
i__1 = *kev - 1;
svout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit,
"_sapps: updated sub diagonal of H for next iteration", (
ftnlen)52);
}
}
arscnd_(&t1);
timing_1.tsapps += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of ssapps | */
/* %---------------% */
} /* ssapps_ */
/* Subroutine */
int slasd2_(integer *nl, integer *nr, integer *sqre, integer *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer * ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq, integer *coltyp, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1, vt2_offset, i__1;
real r__1, r__2;
/* Local variables */
real c__;
integer i__, j, m, n;
real s;
integer k2;
real z1;
integer ct, jp;
real eps, tau, tol;
integer psm[4], nlp1, nlp2, idxi, idxj, ctot[4];
extern /* Subroutine */
int srot_(integer *, real *, integer *, real *, integer *, real *, real *);
integer idxjp, jprev;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
extern real slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *), slamrg_( integer *, integer *, real *, integer *, integer *, integer *);
real hlftol;
extern /* Subroutine */
int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
/* Function Body */
*info = 0;
if (*nl < 1)
{
*info = -1;
}
else if (*nr < 1)
{
*info = -2;
}
else if (*sqre != 1 && *sqre != 0)
{
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n)
{
*info = -10;
}
else if (*ldvt < m)
{
*info = -12;
}
else if (*ldu2 < n)
{
*info = -15;
}
else if (*ldvt2 < m)
{
*info = -17;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SLASD2", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
/* Generate the first part of the vector Z;
and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl;
i__ >= 1;
--i__)
{
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
/* L20: */
}
/* Initialize some reference arrays. */
i__1 = nlp1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
coltyp[i__] = 1;
/* L30: */
}
i__1 = n;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
coltyp[i__] = 2;
/* L40: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
idxq[i__] += nlp1;
/* L50: */
}
/* DSIGMA, IDXC, IDXC, and the first column of U2 */
/* are used as storage space. */
i__1 = n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
/* L60: */
}
slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
/* L70: */
}
/* Calculate the allowable deflation tolerance */
eps = slamch_("Epsilon");
/* Computing MAX */
r__1 = f2c_abs(*alpha);
r__2 = f2c_abs(*beta); // , expr subst
tol = max(r__1,r__2);
/* Computing MAX */
r__2 = (r__1 = d__[n], f2c_abs(r__1));
tol = eps * 8.f * max(r__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
if ((r__1 = z__[j], f2c_abs(r__1)) <= tol)
{
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n)
{
goto L120;
}
}
else
{
jprev = j;
goto L90;
}
/* L80: */
}
L90:
j = jprev;
L100:
++j;
if (j > n)
{
goto L110;
}
if ((r__1 = z__[j], f2c_abs(r__1)) <= tol)
{
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
}
else
{
/* Check if singular values are close enough to allow deflation. */
if ((r__1 = d__[j] - d__[jprev], f2c_abs(r__1)) <= tol)
{
/* Deflation is possible. */
s = z__[jprev];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.f;
/* Apply back the Givens rotation to the left and right */
/* singular vector matrices. */
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1)
{
--idxjp;
}
if (idxj <= nlp1)
{
--idxj;
}
srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & c__1, &c__, &s);
srot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, & c__, &s);
if (coltyp[j] != coltyp[jprev])
{
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
}
else
{
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110: /* Record the last singular value. */
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120: /* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four groups of uniform structure (although one or more of these */
/* groups may be empty). */
for (j = 1;
j <= 4;
++j)
{
ctot[j - 1] = 0;
/* L130: */
}
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the IDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's, starting from the */
/* second column. This applies similarly to the rows of VT. */
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the singular values and corresponding singular vectors into */
/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
/* which were not deflated go into the first K slots of DSIGMA, U2, */
/* and VT2 respectively, while those which were deflated go into the */
/* last N - K slots, except that the first column/row will be treated */
/* separately. */
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1)
{
--idxj;
}
scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
/* L160: */
}
/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
dsigma[1] = 0.f;
hlftol = tol / 2.f;
if (f2c_abs(dsigma[2]) <= hlftol)
{
dsigma[2] = hlftol;
}
if (m > n)
{
z__[1] = slapy2_(&z1, &z__[m]);
if (z__[1] <= tol)
{
c__ = 1.f;
s = 0.f;
z__[1] = tol;
}
else
{
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
}
else
{
if (f2c_abs(z1) <= tol)
{
z__[1] = tol;
}
else
{
z__[1] = z1;
}
}
/* Move the rest of the updating row to Z. */
i__1 = *k - 1;
scopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
/* Determine the first column of U2, the first row of VT2 and the */
/* last row of VT. */
slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
u2[nlp1 + u2_dim1] = 1.f;
if (m > n)
{
i__1 = nlp1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
/* L170: */
}
i__1 = m;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
/* L180: */
}
}
else
{
scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n)
{
scopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
/* The deflated singular values and their corresponding vectors go */
/* into the back of D, U, and V respectively. */
if (n > *k)
{
i__1 = n - *k;
scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) * u_dim1 + 1], ldu);
i__1 = n - *k;
slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + vt_dim1], ldvt);
}
/* Copy CTOT into COLTYP for referencing in SLASD3. */
for (j = 1;
j <= 4;
++j)
{
coltyp[j] = ctot[j - 1];
/* L190: */
}
return 0;
/* End of SLASD2 */
}
/* Subroutine */ int slqt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *l, integer *lda, real *tau, real *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;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), sorglq_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real eps;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with
orthonornmal rows that is defined as the product of k elementary
reflectors.
Given the LQ factorization of an m-by-n matrix A, SLQT02 generates
the orthogonal matrix Q defined by the factorization of the first k
rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
checks that the rows of Q are orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
N >= M >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input) REAL array, dimension (LDA,N)
The m-by-n matrix A which was factorized by SLQT01.
AF (input) REAL array, dimension (LDA,N)
Details of the LQ factorization of A, as returned by SGELQF.
See SGELQF for further details.
Q (workspace) REAL array, dimension (LDA,N)
L (workspace) REAL array, dimension (LDA,M)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= N.
TAU (input) REAL array, dimension (M)
The scalar factors of the elementary reflectors corresponding
to the LQ factorization in AF.
WORK (workspace) REAL 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 - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * 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 */
eps = slamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
slacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)6, (ftnlen)6);
sorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
slaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
slacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
sgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
q[q_offset], lda, &c_b15, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = slange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = slange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
slaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
ssyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of SLQT02 */
} /* slqt02_ */
/* Subroutine */
int slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * 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;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real s, aa, bb, cc, dd, cs, sn;
integer jw;
real evi, evk, foo;
integer kln;
real tau, ulp;
integer lwk1, lwk2;
real beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
logical bulge;
extern /* Subroutine */
int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), sgemm_( char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *);
integer infqr;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
integer kwtop;
extern /* Subroutine */
int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slabad_(real *, real *) ;
extern real slamch_(char *);
extern /* Subroutine */
int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
real safmin;
extern /* Subroutine */
int slarfg_(integer *, real *, real *, integer *, real *);
real safmax;
extern /* Subroutine */
int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
logical sorted;
extern /* Subroutine */
int strexc_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== 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;
--sr;
--si;
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; // , expr subst
jw = min(i__1,i__2);
if (jw <= 2)
{
lwkopt = 1;
}
else
{
/* ==== Workspace query call to SGEHRD ==== */
i__1 = jw - 1;
sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to SORMHR ==== */
i__1 = jw - 1;
sormhr_("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];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
work[1] = (real) lwkopt;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1] = 1.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; // , expr subst
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop)
{
s = 0.f;
}
else
{
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop)
{
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.f;
*ns = 1;
*nd = 0;
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( r__1)); // , expr subst
if (abs(s) <= max(r__2,r__3))
{
*ns = 0;
*nd = 1;
if (kwtop > *ktop)
{
h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
}
}
work[1] = 1.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.) ==== */
slacpy_("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;
scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3);
slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== STREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1;
j <= i__1;
++j)
{
t[j + 2 + j * t_dim1] = 0.f;
t[j + 3 + j * t_dim1] = 0.f;
/* L10: */
}
if (jw > 2)
{
t[jw + (jw - 2) * t_dim1] = 0.f;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns)
{
if (*ns == 1)
{
bulge = FALSE_;
}
else
{
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge)
{
/* ==== Real eigenvalue ==== */
foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * foo; // , expr subst
if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= max(r__2,r__3))
{
/* ==== Deflatable ==== */
--(*ns);
}
else
{
/* ==== Undeflatable. Move it up out of the way. */
/* . (STREXC can not fail in this case.) ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
++ilst;
}
}
else
{
/* ==== Complex conjugate pair ==== */
foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* ns - 1 + *ns * t_dim1], abs(r__2)));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1));
r__4 = (r__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); // , expr subst
/* Computing MAX */
r__5 = smlnum;
r__6 = ulp * foo; // , expr subst
if (max(r__3,r__4) <= max(r__5,r__6))
{
/* ==== Deflatable ==== */
*ns += -2;
}
else
{
/* ==== Undeflatable. Move them up out of the way. */
/* . Fortunately, STREXC does the right thing with */
/* . ILST in case of a rare exchange failure. ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0)
{
s = 0.f;
}
if (*ns < jw)
{
/* ==== sorting diagonal blocks of T improves accuracy for */
/* . graded matrices. Bubble sort deals well with */
/* . exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted)
{
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
L40:
if (k <= kend)
{
if (k == i__ + 1)
{
evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1));
}
else
{
evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = t[i__ + (i__ + 1) * t_dim1], abs(r__2)));
}
if (k == kend)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else if (t[k + 1 + k * t_dim1] == 0.f)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else
{
evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + (k + 1) * t_dim1], abs(r__2)));
}
if (evi >= evk)
{
i__ = k;
}
else
{
sorted = FALSE_;
ifst = i__;
ilst = k;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
if (info == 0)
{
i__ = ilst;
}
else
{
i__ = k;
}
}
if (i__ == kend)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1)
{
if (i__ == infqr + 1)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else if (t[i__ + (i__ - 1) * t_dim1] == 0.f)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else
{
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.f)
{
if (*ns > 1 && s != 0.f)
{
/* ==== Reflect spike back into lower triangle ==== */
scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
slarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.f;
i__1 = jw - 2;
i__2 = jw - 2;
slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]);
i__1 = *lwork - jw;
sgehrd_(&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)
{
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
slacpy_("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;
scopy_(&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 != 0.f)
{
i__1 = *lwork - jw;
sormhr_("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; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh);
/* L70: */
}
/* ==== 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; // , expr subst
kln = min(i__3,i__4);
sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt);
slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh);
/* L80: */
}
}
/* ==== 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; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz);
/* L90: */
}
}
}
/* ==== 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. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR2 ==== */
return 0;
}
/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb,
real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu,
real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *
tau, real *work, integer *info)
{
/* 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;
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
logical wantq, wantu, wantv;
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *), sgerq2_(integer *, integer *, real
*, integer *, real *, real *, integer *), sorg2r_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
), sorm2r_(char *, char *, integer *, integer *, integer *, real *
, integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *), xerbla_(char *, integer *), sgeqpf_(
integer *, integer *, real *, integer *, integer *, real *, real *
, integer *), slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), slapmt_(
logical *, integer *, integer *, real *, integer *, integer *);
logical forwrd;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGGSVP computes orthogonal 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 */
/* transpose of Z. */
/* This decomposition is the preprocessing step for computing the */
/* Generalized Singular Value Decomposition (GSVD), see subroutine */
/* SGGSVD. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': Orthogonal matrix U is computed; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': Orthogonal matrix V is computed; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Orthogonal 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) REAL 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) REAL 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. */
/* K + L = effective numerical rank of (A',B')'. */
/* U (output) REAL array, dimension (LDU,M) */
/* If JOBU = 'U', U contains the orthogonal 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) REAL array, dimension (LDV,M) */
/* If JOBV = 'V', V contains the orthogonal 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) REAL array, dimension (LDQ,N) */
/* If JOBQ = 'Q', Q contains the orthogonal 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) */
/* TAU (workspace) REAL array, dimension (N) */
/* WORK (workspace) REAL 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 SGEQPF 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--iwork;
--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_("SGGSVP", &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: */
}
sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
/* Update A := A*P */
slapmt_(&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__) {
if ((r__1 = b[i__ + i__ * b_dim1], dabs(r__1)) > *tolb) {
++(*l);
}
/* L20: */
}
if (wantv) {
/* Copy the details of V, and form V. */
slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
if (*p > 1) {
i__1 = *p - 1;
slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
ldv);
}
i__1 = min(*p,*n);
sorg2r_(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__) {
b[i__ + j * b_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
}
if (wantq) {
/* Set Q = I and Update Q := Q*P */
slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l) {
/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
a_offset], lda, &work[1], info);
if (wantq) {
/* Update Q := Q*Z' */
sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
&q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
slaset_("Full", l, &i__1, &c_b12, &c_b12, &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__) {
b[i__ + j * b_dim1] = 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;
sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[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__) {
if ((r__1 = a[i__ + i__ * a_dim1], dabs(r__1)) > *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);
sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[(
*n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
if (wantu) {
/* Copy the details of U, and form U */
slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
if (*m > 1) {
i__1 = *m - 1;
i__2 = *n - *l;
slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
, ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
sorg2r_(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;
slapmt_(&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__) {
a[i__ + j * a_dim1] = 0.f;
/* L90: */
}
/* L100: */
}
if (*m > *k) {
i__1 = *m - *k;
i__2 = *n - *l;
slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1],
lda);
}
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
sgerq2_(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;
sormr2_("Right", "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;
slaset_("Full", k, &i__1, &c_b12, &c_b12, &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__) {
a[i__ + j * a_dim1] = 0.f;
/* L110: */
}
/* L120: */
}
}
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], 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);
sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n
- *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 +
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__) {
a[i__ + j * a_dim1] = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of SGGSVP */
} /* sggsvp_ */
/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, m;
real p;
integer ii, lgn;
real eps, tiny;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer lwmin, start;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), slaed0_(integer *, integer *, integer *, real *, real
*, real *, integer *, real *, integer *, real *, integer *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer finish;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *);
integer liwmin, icompz;
real orgnrm;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *),
slasrt_(char *, integer *, real *, integer *);
logical lquery;
integer smlsiz;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
integer storez, strtrw;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the divide and conquer method. */
/* The eigenvectors of a full or band real symmetric matrix can also be */
/* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this */
/* matrix to tridiagonal form. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. See SLAED3 for details. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* = 'V': Compute eigenvectors of original dense symmetric */
/* matrix also. On entry, Z contains the orthogonal */
/* matrix used to reduce the original matrix to */
/* tridiagonal form. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the subdiagonal elements of the tridiagonal matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace/output) REAL 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. */
/* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LWORK must be at least */
/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */
/* where lg( N ) = smallest integer k such */
/* that 2**k >= N. */
/* If COMPZ = 'I' and N > 1 then LWORK must be at least */
/* ( 1 + 4*N + N**2 ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LWORK need */
/* only be max(1,2*(N-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. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */
/* ( 6 + 6*N + 5*N*lg N ). */
/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */
/* ( 3 + 5*N ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LIWORK */
/* need only be 1. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an eigenvalue while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through mod(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info == 0) {
/* Compute the workspace requirements */
smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n <= 1 || icompz == 0) {
liwmin = 1;
lwmin = 1;
} else if (*n <= smlsiz) {
liwmin = 1;
lwmin = *n - 1 << 1;
} else {
lgn = (integer) (log((real) (*n)) / log(2.f));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (icompz == 1) {
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
}
work[1] = (real) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* If the following conditional clause is removed, then the routine */
/* will use the Divide and Conquer routine to compute only the */
/* eigenvalues, which requires (3N + 3N**2) real workspace and */
/* (2 + 5N + 2N lg(N)) integer workspace. */
/* Since on many architectures SSTERF is much faster than any other */
/* algorithm for finding eigenvalues only, it is used here */
/* as the default. If the conditional clause is removed, then */
/* information on the size of workspace needs to be changed. */
/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
if (icompz == 0) {
ssterf_(n, &d__[1], &e[1], info);
goto L50;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
/* solve the problem with another solver. */
if (*n <= smlsiz) {
ssteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
} else {
/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
/* use. */
if (icompz == 1) {
storez = *n * *n + 1;
} else {
storez = 1;
}
if (icompz == 2) {
slaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
}
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
goto L50;
}
eps = slamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L10:
if (start <= *n) {
/* Let FINISH be the position of the next subdiagonal entry */
/* such that E( FINISH ) <= TINY or FINISH = N if no such */
/* subdiagonal exists. The matrix identified by the elements */
/* between START and FINISH constitutes an independent */
/* sub-problem. */
finish = start;
L20:
if (finish < *n) {
tiny = eps * sqrt((r__1 = d__[finish], dabs(r__1))) * sqrt((
r__2 = d__[finish + 1], dabs(r__2)));
if ((r__1 = e[finish], dabs(r__1)) > tiny) {
++finish;
goto L20;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = finish - start + 1;
if (m == 1) {
start = finish + 1;
goto L10;
}
if (m > smlsiz) {
/* Scale. */
orgnrm = slanst_("M", &m, &d__[start], &e[start]);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
start], &m, info);
i__1 = m - 1;
i__2 = m - 1;
slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
start], &i__2, info);
if (icompz == 1) {
strtrw = 1;
} else {
strtrw = start;
}
slaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw +
start * z_dim1], ldz, &work[1], n, &work[storez], &
iwork[1], info);
if (*info != 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
(m + 1) + start - 1;
goto L50;
}
/* Scale back. */
slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
start], &m, info);
} else {
if (icompz == 1) {
/* Since QR won't update a Z matrix which is larger than */
/* the length of D, we must solve the sub-problem in a */
/* workspace and then multiply back into Z. */
ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
work[m * m + 1], info);
slacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
storez], n);
sgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
work[1], &m, &c_b17, &z__[start * z_dim1 + 1],
ldz);
} else if (icompz == 2) {
ssteqr_("I", &m, &d__[start], &e[start], &z__[start +
start * z_dim1], ldz, &work[1], info);
} else {
ssterf_(&m, &d__[start], &e[start], info);
}
if (*info != 0) {
*info = start * (*n + 1) + finish;
goto L50;
}
}
start = finish + 1;
goto L10;
}
/* endwhile */
/* If the problem split any number of times, then the eigenvalues */
/* will not be properly ordered. Here we permute the eigenvalues */
/* (and the associated eigenvectors) into ascending order. */
if (m != *n) {
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L30: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k *
z_dim1 + 1], &c__1);
}
/* L40: */
}
}
}
}
L50:
work[1] = (real) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSTEDC */
} /* sstedc_ */
/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real *
e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer
*ldc, real *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGBBRD reduces a real general m-by-n band matrix A to upper
bidiagonal form B by an orthogonal 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) REAL 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) REAL array, dimension (LDQ,M)
If VECT = 'Q' or 'B', the m-by-m orthogonal 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) REAL array, dimension (LDPT,N)
If VECT = 'P' or 'B', the n-by-n orthogonal 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) REAL 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) REAL array, dimension (2*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 */
/* Table of constant values */
static real c_b8 = 0.f;
static real c_b9 = 1.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;
/* Local variables */
static integer inca;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static integer i__, j, l;
extern logical lsame_(char *, char *);
static logical wantb, wantc;
static integer minmn;
static logical wantq;
static integer j1, j2, kb;
static real ra, rb, rc;
static integer kk, ml, mn, nr, mu;
static real rs;
extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *);
static integer kb1;
extern /* Subroutine */ int slargv_(integer *, real *, integer *, real *,
integer *, real *, integer *);
static integer ml0;
extern /* Subroutine */ int slartv_(integer *, real *, integer *, real *,
integer *, real *, real *, integer *);
static logical wantpt;
static integer mu0, klm, kun, nrt, klu1;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
#define pt_ref(a_1,a_2) pt[(a_2)*pt_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1 * 1;
pt -= pt_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* 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_("SGBBRD", &i__1);
return 0;
}
/* Initialize Q and P' to the unit matrix, if needed */
if (wantq) {
slaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq);
}
if (wantpt) {
slaset_("Full", n, n, &c_b8, &c_b9, &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 sines of the plane rotations are stored in WORK(1:max(m,n))
and the cosines in WORK(max(m,n)+1:2*max(m,n)). */
mn = max(*m,*n);
/* 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) {
slargv_(&nr, &ab_ref(klu1, j1 - klm - 1), &inca, &work[j1]
, &kb1, &work[mn + 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) {
slartv_(&nrt, &ab_ref(klu1 - l, j1 - klm + l - 1), &
inca, &ab_ref(klu1 - l + 1, j1 - klm + l - 1),
&inca, &work[mn + 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 */
slartg_(&ab_ref(*ku + ml - 1, i__), &ab_ref(*ku + ml,
i__), &work[mn + i__ + ml - 1], &work[i__ +
ml - 1], &ra);
ab_ref(*ku + ml - 1, i__) = ra;
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;
srot_(&i__3, &ab_ref(*ku + ml - 2, i__ + 1), &
i__6, &ab_ref(*ku + ml - 1, i__ + 1), &
i__7, &work[mn + 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)
{
srot_(m, &q_ref(1, j - 1), &c__1, &q_ref(1, j), &c__1,
&work[mn + j], &work[j]);
/* 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)
{
srot_(ncc, &c___ref(j - 1, 1), ldc, &c___ref(j, 1),
ldc, &work[mn + 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) */
work[j + kun] = work[j] * ab_ref(1, j + kun);
ab_ref(1, j + kun) = work[mn + j] * ab_ref(1, j + kun);
/* L40: */
}
/* generate plane rotations to annihilate nonzero elements
which have been generated above the band */
if (nr > 0) {
slargv_(&nr, &ab_ref(1, j1 + kun - 1), &inca, &work[j1 +
kun], &kb1, &work[mn + 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) {
slartv_(&nrt, &ab_ref(l + 1, j1 + kun - 1), &inca, &
ab_ref(l, j1 + kun), &inca, &work[mn + 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 */
slartg_(&ab_ref(*ku - mu + 3, i__ + mu - 2), &ab_ref(*
ku - mu + 2, i__ + mu - 1), &work[mn + i__ +
mu - 1], &work[i__ + mu - 1], &ra);
ab_ref(*ku - mu + 3, i__ + mu - 2) = ra;
/* Computing MIN */
i__3 = *kl + mu - 2, i__5 = *m - i__;
i__4 = min(i__3,i__5);
srot_(&i__4, &ab_ref(*ku - mu + 4, i__ + mu - 2), &
c__1, &ab_ref(*ku - mu + 3, i__ + mu - 1), &
c__1, &work[mn + 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)
{
srot_(n, &pt_ref(j + kun - 1, 1), ldpt, &pt_ref(j +
kun, 1), ldpt, &work[mn + j + kun], &work[j +
kun]);
/* 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) */
work[j + kb] = work[j + kun] * ab_ref(klu1, j + kun);
ab_ref(klu1, j + kun) = work[mn + j + kun] * ab_ref(klu1,
j + kun);
/* L70: */
}
if (ml > ml0) {
--ml;
} else {
--mu;
}
/* L80: */
}
/* L90: */
}
}
if (*ku == 0 && *kl > 0) {
/* A has been reduced to lower bidiagonal form
Transform lower bidiagonal form to upper bidiagonal by applying
plane rotations from the left, storing diagonal elements in D
and off-diagonal elements in E
Computing MIN */
i__2 = *m - 1;
i__1 = min(i__2,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&ab_ref(1, i__), &ab_ref(2, i__), &rc, &rs, &ra);
d__[i__] = ra;
if (i__ < *n) {
e[i__] = rs * ab_ref(1, i__ + 1);
ab_ref(1, i__ + 1) = rc * ab_ref(1, i__ + 1);
}
if (wantq) {
srot_(m, &q_ref(1, i__), &c__1, &q_ref(1, i__ + 1), &c__1, &
rc, &rs);
}
if (wantc) {
srot_(ncc, &c___ref(i__, 1), ldc, &c___ref(i__ + 1, 1), ldc, &
rc, &rs);
}
/* L100: */
}
if (*m <= *n) {
d__[*m] = ab_ref(1, *m);
}
} else if (*ku > 0) {
/* A has been reduced to upper bidiagonal form */
if (*m < *n) {
/* Annihilate a(m,m+1) by applying plane rotations from the
right, storing diagonal elements in D and off-diagonal
elements in E */
rb = ab_ref(*ku, *m + 1);
for (i__ = *m; i__ >= 1; --i__) {
slartg_(&ab_ref(*ku + 1, i__), &rb, &rc, &rs, &ra);
d__[i__] = ra;
if (i__ > 1) {
rb = -rs * ab_ref(*ku, i__);
e[i__ - 1] = rc * ab_ref(*ku, i__);
}
if (wantpt) {
srot_(n, &pt_ref(i__, 1), ldpt, &pt_ref(*m + 1, 1), ldpt,
&rc, &rs);
}
/* L110: */
}
} else {
/* Copy off-diagonal elements to E and diagonal elements to D */
i__1 = minmn - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = ab_ref(*ku, i__ + 1);
/* L120: */
}
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = ab_ref(*ku + 1, i__);
/* L130: */
}
}
} else {
/* A is diagonal. Set elements of E to zero and copy diagonal
elements to D. */
i__1 = minmn - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = 0.f;
/* L140: */
}
i__1 = minmn;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = ab_ref(1, i__);
/* L150: */
}
}
return 0;
/* End of SGBBRD */
} /* sgbbrd_ */
/* 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 sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
selctg, integer *n, real *a, integer *lda, real *b, integer *ldb,
integer *sdim, real *alphar, real *alphai, real *beta, real *vsl,
integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork,
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
=======
SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
the generalized eigenvalues, the generalized real Schur form (S,T),
optionally, the left and/or right matrices of Schur vectors (VSL and
VSR). This gives the generalized Schur factorization
(A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
Optionally, it also orders the eigenvalues so that a selected cluster
of eigenvalues appears in the leading diagonal blocks of the upper
quasi-triangular matrix S and the upper triangular matrix T.The
leading columns of VSL and VSR then form an orthonormal basis for the
corresponding left and right eigenspaces (deflating subspaces).
(If only the generalized eigenvalues are needed, use the driver
SGGEV 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 or both being zero.
A pair of matrices (S,T) is in generalized real Schur form if T is
upper triangular with non-negative diagonal and S is block upper
triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
to real generalized eigenvalues, while 2-by-2 blocks of S will be
"standardized" by making the corresponding elements of T have the
form:
[ a 0 ]
[ 0 b ]
and the pair of corresponding 2-by-2 blocks in S and T will have a
complex conjugate pair of generalized eigenvalues.
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 three REAL 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 (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
one of a complex conjugate pair of eigenvalues is selected,
then both complex eigenvalues are selected.
Note that in the ill-conditioned case, a selected complex
eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
in this case.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) REAL 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) REAL 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. (Complex conjugate pairs for which
SELCTG is true for either eigenvalue count as 2.)
ALPHAR (output) REAL array, dimension (N)
ALPHAI (output) REAL array, dimension (N)
BETA (output) REAL array, dimension (N)
On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
and BETA(j),j=1,...,N are the diagonals of the complex Schur
form (S,T) that would result if the 2-by-2 diagonal blocks of
the real Schur form of (A,B) were further reduced to
triangular form using 2-by-2 complex unitary transformations.
If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
positive, then the j-th and (j+1)-st eigenvalues are a
complex conjugate pair, with ALPHAI(j+1) negative.
Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
may easily over- or underflow, and BETA(j) may even be zero.
Thus, the user should avoid naively computing the ratio.
However, ALPHAR and ALPHAI 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) REAL 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) REAL 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) REAL array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 8*N+16.
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.
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 ALPHAR(j), ALPHAI(j), and BETA(j) should
be correct for j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in SHGEQZ.
=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 STGSEN.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c_n1 = -1;
static real c_b33 = 0.f;
static real c_b34 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real anrm, bnrm;
static integer idum[1], ierr, itau, iwrk;
static real pvsl, pvsr;
static integer i__;
extern logical lsame_(char *, char *);
static integer ileft, icols;
static logical cursl, ilvsl, ilvsr;
static integer irows;
static logical lst2sl;
extern /* Subroutine */ int slabad_(real *, real *);
static integer ip;
extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, integer *
), sggbal_(char *, integer *, real *, integer *,
real *, integer *, integer *, integer *, real *, real *, real *,
integer *);
static logical ilascl, ilbscl;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
static real safmin;
extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, integer *);
static real safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ijobvl, iright;
extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *);
static integer ijobvr;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
static real anrmto, bnrmto;
static logical lastsl;
extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, real *, real *, real *, integer *, real *, integer *, real *,
integer *, integer *), stgsen_(integer *,
logical *, logical *, logical *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, integer *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *);
static integer minwrk, maxwrk;
static real smlnum;
extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
static logical wantst, lquery;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
static real dif[2];
static integer ihi, ilo;
static real eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vsl_ref(a_1,a_2) vsl[(a_2)*vsl_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--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;
--work;
--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 = -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 || lquery)) {
minwrk = (*n + 1) * 7 + 16;
maxwrk = (*n + 1) * 7 + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &c__1,
n, &c__0, (ftnlen)6, (ftnlen)1) + 16;
if (ilvsl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n + 1) * 7 + *n * ilaenv_(&c__1, "SORGQR",
" ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
}
work[1] = (real) maxwrk;
}
if (*lwork < minwrk && ! lquery) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGES ", &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");
safmin = slamch_("S");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
smlnum = sqrt(safmin) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrix to make it more nearly triangular
(Workspace: need 6*N + 2*N space for storing balancing factors) */
ileft = 1;
iright = *n + 1;
iwrk = iright + *n;
sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B)
(Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwrk;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
sgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Apply the orthogonal transformation to matrix A
(Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
sormqr_("L", "T", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VSL
(Workspace: need N, prefer N*NB) */
if (ilvsl) {
slaset_("Full", n, n, &c_b33, &c_b34, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
slacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vsl_ref(ilo +
1, ilo), ldvsl);
i__1 = *lwork + 1 - iwrk;
sorgqr_(&irows, &irows, &irows, &vsl_ref(ilo, ilo), ldvsl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
/* Initialize VSR */
if (ilvsr) {
slaset_("Full", n, n, &c_b33, &c_b34, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
/* Perform QZ algorithm, computing Schur vectors if desired
(Workspace: need N) */
iwrk = itau;
i__1 = *lwork + 1 - iwrk;
shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &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 if desired
(Workspace: need 4*N+16 ) */
*sdim = 0;
if (wantst) {
/* Undo scaling on eigenvalues before SELCTGing */
if (ilascl) {
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
n, &ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
n, &ierr);
}
if (ilbscl) {
slascl_("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)(&alphar[i__], &alphai[i__], &beta[i__]);
/* L10: */
}
i__1 = *lwork - iwrk + 1;
stgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[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) {
sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &ierr);
}
if (ilvsr) {
sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &ierr);
}
/* Check if unscaling would cause over/underflow, if so, rescale
(ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
if (ilascl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.f) {
if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
i__] > anrm / anrmto) {
work[1] = (r__1 = a_ref(i__, i__) / alphar[i__], dabs(
r__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
} else if (alphai[i__] / safmax > anrmto / anrm || safmin /
alphai[i__] > anrm / anrmto) {
work[1] = (r__1 = a_ref(i__, i__ + 1) / alphai[i__], dabs(
r__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
/* L50: */
}
}
if (ilbscl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.f) {
if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
> bnrm / bnrmto) {
work[1] = (r__1 = b_ref(i__, i__) / beta[i__], dabs(r__1))
;
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
/* L60: */
}
}
/* Undo scaling */
if (ilascl) {
slascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
slascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
ierr);
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
if (wantst) {
/* Check if reordering is correct */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
if (alphai[i__] == 0.f) {
if (cursl) {
++(*sdim);
}
ip = 0;
if (cursl && ! lastsl) {
*info = *n + 2;
}
} else {
if (ip == 1) {
/* Last eigenvalue of conjugate pair */
cursl = cursl || lastsl;
lastsl = cursl;
if (cursl) {
*sdim += 2;
}
ip = -1;
if (cursl && ! lst2sl) {
*info = *n + 2;
}
} else {
/* First eigenvalue of conjugate pair */
ip = 1;
}
}
lst2sl = lastsl;
lastsl = cursl;
/* L30: */
}
}
L40:
work[1] = (real) maxwrk;
return 0;
/* End of SGGES */
} /* sgges_ */
/* Subroutine */ int sqrt03_(integer *m, integer *n, integer *k, real *af,
real *c__, real *cc, real *q, integer *lda, real *tau, real *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 */
integer j, mc, nc;
real eps;
char side[1];
integer info, iside;
extern logical lsame_(char *, char *);
real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real cnorm;
char trans[1];
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
integer itrans;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*), sorgqr_(integer *, integer *, integer *, real *, integer *,
real *, real *, integer *, integer *), sormqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, 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 */
/* ======= */
/* SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* SQRT03 compares the results of a call to SORMQR with the results of */
/* forming Q explicitly by a call to SORGQR and then performing matrix */
/* multiplication by a call to SGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The order of the orthogonal matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of rows or columns of the matrix C; C is m-by-n if */
/* Q is applied from the left, or n-by-m if Q is applied from */
/* the right. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. M >= K >= 0. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the QR factorization of an m-by-n matrix, as */
/* returnedby SGEQRF. See SGEQRF for further details. */
/* C (workspace) REAL array, dimension (LDA,N) */
/* CC (workspace) REAL array, dimension (LDA,N) */
/* Q (workspace) REAL array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the QR factorization in AF. */
/* WORK (workspace) REAL 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 m-by-m orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = slamch_("Epsilon");
/* Copy the first k columns of the factorization to the array Q */
slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *m - 1;
slacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)6, (ftnlen)6);
sorgqr_(m, m, 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 = *m;
nc = *n;
} else {
*(unsigned char *)side = 'R';
mc = *n;
nc = *m;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = slange_("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 = 'T';
}
/* Copy C */
slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)6, (ftnlen)6);
sormqr_(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")) {
sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of SQRT03 */
} /* sqrt03_ */
/* Subroutine */ int sdrvsy_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
real *afac, real *ainv, real *b, real *x, real *xact, real *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a,\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,a,\002, FACT='\002,a1,\002', UPLO='\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[2];
char ch__1[2];
/* Local variables */
integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode, imat, info;
char path[3], dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nbmin;
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
integer lwork;
logical zerot;
char xtype[1];
real rcondc;
real cndnum, ainvnm;
real result[6];
/* 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.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVSY tests the driver routines SSYSV 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) REAL array, dimension (NMAX*NMAX) */
/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(2,NRHS)) */
/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 10;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with SLATB4 and generate a test matrix */
/* with SLATMS. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of the */
/* matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.f;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.f;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.f;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with */
/* the value returned by SSYSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
/* Factor the matrix A. */
slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
ssytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
&lwork, &info);
/* Compute inv(A) and take its norm. */
slacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
ssytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
ainvnm = slansy_("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, "SLARHS", (ftnlen)32, (ftnlen)6);
slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test SSYSV --- */
if (ifact == 2) {
slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using SSYSV. */
s_copy(srnamc_1.srnamt, "SSYSV ", (ftnlen)32, (ftnlen)
6);
ssysv_(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 SSYSV . */
if (info != k) {
alaerh_(path, "SSYSV ", &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. */
ssyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
1], &ainv[1], &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not pass */
/* the threshold. */
i__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, "SSYSV ", (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 SSYSVX --- */
if (ifact == 2) {
slaset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
}
slaset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SSYSVX. */
s_copy(srnamc_1.srnamt, "SSYSVX", (ftnlen)32, (ftnlen)6);
ssysvx_(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, &
iwork[n + 1], &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from SSYSVX. */
if (info != k) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SSYSVX", &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. */
ssyt01_(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. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
spot05_(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 SSYSVX 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, "SSYSVX", (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 SDRVSY */
} /* sdrvsy_ */
/* Subroutine */ int sdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, real *a, integer *lda, real *h__, real *wr, real *wi,
real *wr1, real *wi1, real *vl, integer *ldvl, real *vr, integer *
ldvr, real *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
scale1, real *result, real *work, integer *nwork, integer *iwork,
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 SDRVVX: \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 -- Real Eigenvalue-Eigenvector De"
"composition\002,\002 Expert Driver\002,/\002 Matrix types (see S"
"DRVVX 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;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static integer ibal;
static real cond;
static integer jcol;
static char path[3];
static integer nmax;
static real unfl, ovfl;
static integer i__, j, n;
static logical badnn;
static integer nfail, imode, iinfo;
static real conds;
extern /* Subroutine */ int sget23_(logical *, char *, integer *, real *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, real *, real *, real *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, integer *, integer *, integer *);
static real anorm;
static integer jsize, nerrs, itype, jtype, ntest;
static real rtulp;
static char balanc[1];
extern /* Subroutine */ int slabad_(real *, real *);
static char adumma[1*1];
extern doublereal slamch_(char *);
static integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
integer *, real *, real *, char *, char *, char *, char *, real *,
integer *, real *, integer *, integer *, real *, real *, integer
*, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slatmr_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, char *, char *,
real *, integer *, real *, real *, integer *, real *, char *,
integer *, integer *, integer *, real *, real *, char *, real *,
integer *, integer *, integer *);
static integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*), slatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, real *, integer *, real *, integer *);
static real ulpinv;
static integer nnwork;
static real rtulpi;
static integer mtypes, ntestt, iwk;
static real ulp;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 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___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SDRVVX checks the nonsymmetric eigenvalue problem expert driver
SGEEVX.
SDRVVX 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 SDRVVX 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 block diagonal matrix, with a 1x1 block for each
real eigenvalue and a 2x2 block for each complex conjugate
pair. If eigenvalues j and j+1 are a complex conjugate pair,
so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
2 x 2 block corresponding to the pair will be:
( wr wi )
( -wi wr )
Such a block multiplying an n x 2 matrix ( ur ui ) on the
right will be the same as multiplying ur + i*ui by wr + i*wi.
(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 signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(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 orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 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 (-1,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 SGEEVX 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 SGEEVX 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 SDRVVX 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) REAL 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 the arrays A and H.
LDA >= max(NN,12), since 12 is the dimension of the largest
matrix in the precomputed input file.
H (workspace) REAL array, dimension
(LDA, max(NN,12))
Another copy of the test matrix A, modified by SGEEVX.
WR (workspace) REAL array, dimension (max(NN))
WI (workspace) REAL array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A.
On exit, WR + WI*i are the eigenvalues of the matrix in A.
WR1 (workspace) REAL array, dimension (max(NN,12))
WI1 (workspace) REAL array, dimension (max(NN,12))
Like WR, WI, these arrays contain the eigenvalues of A,
but those computed when SGEEVX only computes a partial
eigendecomposition, i.e. not the eigenvalues and left
and right eigenvectors.
VL (workspace) REAL 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) REAL 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) REAL 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))
RCONDV (workspace) REAL array, dimension (N)
RCONDV holds the computed reciprocal condition numbers
for eigenvectors.
RCNDV1 (workspace) REAL array, dimension (N)
RCNDV1 holds more computed reciprocal condition numbers
for eigenvectors.
RCDVIN (workspace) REAL array, dimension (N)
When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
condition numbers for eigenvectors to be compared with
RCONDV.
RCONDE (workspace) REAL array, dimension (N)
RCONDE holds the computed reciprocal condition numbers
for eigenvalues.
RCNDE1 (workspace) REAL array, dimension (N)
RCNDE1 holds more computed reciprocal condition numbers
for eigenvalues.
RCDEIN (workspace) REAL array, dimension (N)
When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
condition numbers for eigenvalues to be compared with
RCONDE.
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) REAL 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.
IWORK (workspace) INTEGER array, dimension (2*max(NN,12))
INFO (output) INTEGER
If 0, then successful exit.
If <0, then input paramter -INFO is incorrect.
If >0, SLATMR, SLATMS, SLATME or SGET23 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.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--wr;
--wi;
--wr1;
--wi1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1 * 1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--iwork;
/* Function Body */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed
problems */
nmax = 12;
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 = -17;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -19;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -21;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
*info = -32;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVVX", &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:
slaset_("Full", lda, &n, &c_b18, &c_b18, &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) {
a_ref(jcol, jcol) = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[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;
}
*(unsigned char *)&adumma[0] = ' ';
slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a_ref(3, 1)
, lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a_ref(3, n
- 1), lda);
slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a_ref(n, 1),
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___33.ciunit = *nounit;
s_wsfe(&io___33);
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 * 3;
} else if (iwk == 2) {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 6 + 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 */
sget23_(&c_false, balanc, &jtype, thresh, ioldsd, nounit,
&n, &a[a_offset], lda, &h__[h_offset], &wr[1], &
wi[1], &wr1[1], &wi1[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, &iwork[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___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, path, (ftnlen)3);
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);
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 <= 9; ++j) {
if (result[j] >= *thresh) {
io___45.ciunit = *nounit;
s_wsfe(&io___45);
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___46.ciunit = *niunit;
i__1 = s_rsle(&io___46);
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 = 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__4, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(real))
;
}
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 *)&wr1[i__], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wi1[i__], (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();
/* L190: */
}
/* Computing 2nd power */
i__2 = n;
i__1 = n * 6 + (i__2 * i__2 << 1);
sget23_(&c_true, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset],
lda, &h__[h_offset], &wr[1], &wi[1], &wr1[1], &wi1[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, &
iwork[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___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
e_wsfe();
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
io___53.ciunit = *nounit;
s_wsfe(&io___53);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 11; ++j) {
if (result[j] >= *thresh) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
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 SDRVVX */
} /* sdrvvx_ */
/* Subroutine */ int sstt21_(integer *n, integer *kband, real *ad, real *ae,
real *sd, real *se, real *u, integer *ldu, real *work, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static real unfl;
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
static real temp1, temp2;
static integer j;
extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *), sgemm_(
char *, char *, integer *, integer *, integer *, real *, real *,
integer *, real *, integer *, real *, real *, integer *);
static real anorm, wnorm;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real ulp;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTT21 checks a decomposition of the form
A = U S U'
where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | A - U S U' | / ( |A| n ulp )
RESULT(2) = | I - UU' | / ( n ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, SSTT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is symmetric tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be symmetric tridiagonal.
AE (input) REAL array, dimension (N-1)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix S.
SE (input) REAL array, dimension (N-1)
The off-diagonal of the (symmetric tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
(1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
element, etc.
U (input) REAL array, dimension (LDU, N)
The orthogonal matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) REAL array, dimension (N*(N+1))
RESULT (output) REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified.
=====================================================================
1) Constants
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
slaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
anorm = 0.f;
temp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] = ad[j];
work[(*n + 1) * (j - 1) + 2] = ae[j];
temp2 = (r__1 = ae[j], dabs(r__1));
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
anorm = dmax(r__2,r__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = ad[*n];
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
r__3);
anorm = dmax(r__2,unfl);
/* Norm of A - USU' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -sd[j];
ssyr_("L", n, &r__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
r__1 = -se[j];
ssyr2_("L", n, &r__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = slansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU' - I */
sgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b5, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.f;
/* L40: */
}
/* Computing MIN
Computing 2nd power */
i__1 = *n;
r__1 = (real) (*n), r__2 = slange_("1", n, n, &work[1], n, &work[i__1 *
i__1 + 1]);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of SSTT21 */
} /* sstt21_ */
/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a,
integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
*beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
real eps;
logical ilv;
real absb, anrm, bnrm;
integer itau;
real temp;
logical ilvl, ilvr;
integer lopt;
real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
integer ileft, iinfo, icols, iwork, irows;
real salfai;
real salfar;
real safmin;
real safmax;
char chtemp[1];
logical ldumma[1];
integer ijobvl, iright;
logical ilimit;
integer ijobvr;
real onepls;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine SGGEV. */
/* SGEGV computes the eigenvalues and, optionally, the left and/or right */
/* eigenvectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, */
/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
/* that */
/* A*x = lambda*B*x. */
/* An alternate form is to find the eigenvalues mu and corresponding */
/* eigenvectors y such that */
/* mu*A*y = B*y. */
/* These two forms are equivalent with mu = 1/lambda and x = y if */
/* neither lambda nor mu is zero. In order to deal with the case that */
/* lambda or mu is zero or small, two values alpha and beta are returned */
/* for each eigenvalue, such that lambda = alpha/beta and */
/* mu = beta/alpha. */
/* The vectors x and y in the above equations are right eigenvectors of */
/* the matrix pair (A,B). Vectors u and v satisfying */
/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
/* are left eigenvectors of (A,B). */
/* Note: this routine performs "full balancing" on A and B -- see */
/* "Further Details", below. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': do not compute the left generalized eigenvectors; */
/* = 'V': compute the left generalized eigenvectors (returned */
/* in VL). */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': do not compute the right generalized eigenvectors; */
/* = 'V': compute the right generalized eigenvectors (returned */
/* in VR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VL, and VR. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
/* contains the real Schur form of A from the generalized Schur */
/* factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only the diagonal */
/* blocks from the Schur form will be correct. See SGGHRD and */
/* SHGEQZ for details. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) REAL array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
/* upper triangular matrix obtained from B in the generalized */
/* Schur factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only those elements of */
/* B corresponding to the diagonal blocks from the Schur form of */
/* A will be correct. See SGGHRD and SHGEQZ for details. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) REAL array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue of */
/* GNEP. */
/* ALPHAI (output) REAL array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and */
/* (j+1)-st eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) REAL array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(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. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
/* in the columns of VL, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* u(j) = VL(:,j) + i*VL(:,j+1) */
/* and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVL = 'N'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the matrix VL. LDVL >= 1, and */
/* if JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
/* in the columns of VR, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* x(j) = VR(:,j) + i*VR(:,j+1) */
/* and */
/* x(j+1) = VR(:,j) - i*VR(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVR = 'N'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the matrix VR. LDVR >= 1, and */
/* if JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) REAL 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,8*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR; */
/* The optimal LWORK is: */
/* 2*N + MAX( 6*N, 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. No eigenvectors have been */
/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from SGGBAL */
/* =N+2: error return from SGEQRF */
/* =N+3: error return from SORMQR */
/* =N+4: error return from SORGQR */
/* =N+5: error return from SGGHRD */
/* =N+6: error return from SHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from STGEVC */
/* =N+8: error return from SGGBAK (computing VL) */
/* =N+9: error return from SGGBAK (computing VR) */
/* =N+10: error return from SLASCL (various calls) */
/* Further Details */
/* =============== */
/* Balancing */
/* --------- */
/* This driver calls SGGBAL to both permute and scale rows and columns */
/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
/* and PL*B*R will be upper triangular except for the diagonal blocks */
/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
/* possible. The diagonal scaling matrices DL and DR are chosen so */
/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
/* one (except for the elements that start out zero.) */
/* After the eigenvalues and eigenvectors of the balanced matrices */
/* have been computed, SGGBAK transforms the eigenvectors back to what */
/* they would have been (in perfect arithmetic) if they had not been */
/* balanced. */
/* Contents of A and B on Exit */
/* -------- -- - --- - -- ---- */
/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
/* both), then on exit the arrays A and B will contain the real Schur */
/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
/* are computed, then only the diagonal blocks will be correct. */
/* [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations", */
/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */
/* ===================================================================== */
/* 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;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 3;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (real) lwkopt;
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 (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -12;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = *n * 6, i__2 = *n * (nb + 1);
lopt = (*n << 1) + max(i__1,i__2);
work[1] = (real) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEGV ", &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");
safmin += safmin;
safmax = 1.f / safmin;
onepls = eps * 4 + 1.f;
/* Scale A */
anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
anrm1 = anrm;
anrm2 = 1.f;
if (anrm < 1.f) {
if (safmax * anrm < 1.f) {
anrm1 = safmin;
anrm2 = safmax * anrm;
}
}
if (anrm > 0.f) {
slascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Scale B */
bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
bnrm1 = bnrm;
bnrm2 = 1.f;
if (bnrm < 1.f) {
if (safmax * bnrm < 1.f) {
bnrm1 = safmin;
bnrm2 = safmax * bnrm;
}
}
if (bnrm > 0.f) {
slascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (8*N words -- "work" requires 6*N words) */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L120;
}
/* Reduce B to triangular form, and initialize VL and/or VR */
irows = ihi + 1 - ilo;
if (ilv) {
icols = *n + 1 - ilo;
} else {
icols = irows;
}
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L120;
}
i__1 = *lwork + 1 - iwork;
sormqr_("L", "T", &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__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L120;
}
if (ilvl) {
slaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl)
;
i__1 = irows - 1;
i__2 = irows - 1;
slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
1 + ilo * vl_dim1], ldvl);
i__1 = *lwork + 1 - iwork;
sorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L120;
}
}
if (ilvr) {
slaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form */
if (ilv) {
/* Eigenvectors requested -- work on whole matrix. */
sgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
} else {
sgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
&b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &iinfo);
}
if (iinfo != 0) {
*info = *n + 5;
goto L120;
}
/* Perform QZ algorithm */
iwork = itau;
if (ilv) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwork;
shgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + 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 L120;
}
if (ilv) {
/* Compute Eigenvectors (STGEVC requires 6*N words of workspace) */
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L120;
}
/* Undo balancing on VL and VR, rescale */
if (ilvl) {
sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vl[vl_offset], ldvl, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.f) {
goto L50;
}
temp = 0.f;
if (alphai[jc] == 0.f) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
r__2 = temp, r__3 = (r__1 = vl[jr + jc * vl_dim1],
dabs(r__1));
temp = dmax(r__2,r__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
r__3 = temp, r__4 = (r__1 = vl[jr + jc * vl_dim1],
dabs(r__1)) + (r__2 = vl[jr + (jc + 1) *
vl_dim1], dabs(r__2));
temp = dmax(r__3,r__4);
}
}
if (temp < safmin) {
goto L50;
}
temp = 1.f / temp;
if (alphai[jc] == 0.f) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
}
}
L50:
;
}
}
if (ilvr) {
sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vr[vr_offset], ldvr, &iinfo);
if (iinfo != 0) {
*info = *n + 9;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.f) {
goto L100;
}
temp = 0.f;
if (alphai[jc] == 0.f) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
r__2 = temp, r__3 = (r__1 = vr[jr + jc * vr_dim1],
dabs(r__1));
temp = dmax(r__2,r__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
r__3 = temp, r__4 = (r__1 = vr[jr + jc * vr_dim1],
dabs(r__1)) + (r__2 = vr[jr + (jc + 1) *
vr_dim1], dabs(r__2));
temp = dmax(r__3,r__4);
}
}
if (temp < safmin) {
goto L100;
}
temp = 1.f / temp;
if (alphai[jc] == 0.f) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
}
}
L100:
;
}
}
/* End of eigenvector calculation */
}
/* Undo scaling in alpha, beta */
/* Note: this does not give the alpha and beta for the unscaled */
/* problem. */
/* Un-scaling is limited to avoid underflow in alpha and beta */
/* if they are significant. */
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
absar = (r__1 = alphar[jc], dabs(r__1));
absai = (r__1 = alphai[jc], dabs(r__1));
absb = (r__1 = beta[jc], dabs(r__1));
salfar = anrm * alphar[jc];
salfai = anrm * alphai[jc];
sbeta = bnrm * beta[jc];
ilimit = FALSE_;
scale = 1.f;
/* Check for significant underflow in ALPHAI */
/* Computing MAX */
r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
absb;
if (dabs(salfai) < safmin && absai >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX */
r__1 = onepls * safmin, r__2 = anrm2 * absai;
scale = onepls * safmin / anrm1 / dmax(r__1,r__2);
} else if (salfai == 0.f) {
/* If insignificant underflow in ALPHAI, then make the */
/* conjugate eigenvalue real. */
if (alphai[jc] < 0.f && jc > 1) {
alphai[jc - 1] = 0.f;
} else if (alphai[jc] > 0.f && jc < *n) {
alphai[jc + 1] = 0.f;
}
}
/* Check for significant underflow in ALPHAR */
/* Computing MAX */
r__1 = safmin, r__2 = eps * absai, r__1 = max(r__1,r__2), r__2 = eps *
absb;
if (dabs(salfar) < safmin && absar >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
r__3 = onepls * safmin, r__4 = anrm2 * absar;
r__1 = scale, r__2 = onepls * safmin / anrm1 / dmax(r__3,r__4);
scale = dmax(r__1,r__2);
}
/* Check for significant underflow in BETA */
/* Computing MAX */
r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
absai;
if (dabs(sbeta) < safmin && absb >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
r__3 = onepls * safmin, r__4 = bnrm2 * absb;
r__1 = scale, r__2 = onepls * safmin / bnrm1 / dmax(r__3,r__4);
scale = dmax(r__1,r__2);
}
/* Check for possible overflow when limiting scaling */
if (ilimit) {
/* Computing MAX */
r__1 = dabs(salfar), r__2 = dabs(salfai), r__1 = max(r__1,r__2),
r__2 = dabs(sbeta);
temp = scale * safmin * dmax(r__1,r__2);
if (temp > 1.f) {
scale /= temp;
}
if (scale < 1.f) {
ilimit = FALSE_;
}
}
/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */
if (ilimit) {
salfar = scale * alphar[jc] * anrm;
salfai = scale * alphai[jc] * anrm;
sbeta = scale * beta[jc] * bnrm;
}
alphar[jc] = salfar;
alphai[jc] = salfai;
beta[jc] = sbeta;
}
L120:
work[1] = (real) lwkopt;
return 0;
/* End of SGEGV */
} /* sgegv_ */
void initialize (int argc, char **argv, int * N_p, int * DIM_p)
{
int ISEED[4] = {0,0,0,1};
int IONE=1;
int DIM;
char UPLO='n';
float FZERO=0.0;
int i;
if (argc==2)
{
DIM=atoi(argv[1]);
}
else
{
printf("usage: %s DIM\n",argv[0]);
exit(0);
}
// matrix init
int N=BSIZE*DIM;
int NN=N*N;
*N_p=N;
*DIM_p=DIM;
// linear matrix
float *Alin = (float *) malloc(NN * sizeof(float));
float *Blin = (float *) malloc(NN * sizeof(float));
float *Clin = (float *) malloc(NN * sizeof(float));
// fill the matrix with random values
slarnv_(&IONE, ISEED, &NN, Alin);
slarnv_(&IONE, ISEED, &NN, Blin);
slaset_(&UPLO,&N,&N,&FZERO,&FZERO,Clin,&N);
A = (float **) malloc(DIM*DIM*sizeof(float *));
B = (float **) malloc(DIM*DIM*sizeof(float *));
C = (float **) malloc(DIM*DIM*sizeof(float *));
#if 1
#if 1
for (i = 0; i < DIM*DIM; i++)
{
A[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
B[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
C[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
// printf( "A[%d]=%p %p %p\n", i, A[i], B[i], C[i] );
}
#else
for (i = 0; i < DIM*DIM; i++) {
A[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
// printf( "A[%d]=%p\n", i, A[i] );
}
for (i = 0; i < DIM*DIM; i++)
B[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
for (i = 0; i < DIM*DIM; i++)
C[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
#endif
#else
float * A_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
float * B_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
float * C_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
for (i = 0; i < DIM*DIM; i++)
{
A[i] = &A_scratch[i*BSIZE*BSIZE];
B[i] = &B_scratch[i*BSIZE*BSIZE];
C[i] = &C_scratch[i*BSIZE*BSIZE];
// printf( "A[%d]=%p\n", i, A[i] );
}
#endif
convert_to_blocks(DIM, N, Alin, (void *)A);
convert_to_blocks(DIM, N, Blin, (void *)B);
convert_to_blocks(DIM, N, Clin, (void *)C);
free(Alin);
free(Blin);
free(Clin);
}
/* Subroutine */ int schktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, real *thresh, logical *tsterr, real *a,
real *copya, real *s, real *copys, real *tau, real *work, integer *
nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
real eps;
integer mode, info;
char path[3];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], imode, mnmin, nerrs;
extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
real *, integer *);
integer lwork;
extern doublereal srzt01_(integer *, integer *, real *, real *, integer *,
real *, real *, integer *), srzt02_(integer *, integer *, real *,
integer *, real *, real *, integer *), stzt01_(integer *,
integer *, real *, real *, integer *, real *, real *, integer *),
stzt02_(integer *, integer *, real *, integer *, real *, real *,
integer *);
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *), slaord_(char *, integer *, real *, integer
*), slacpy_(char *, integer *, integer *, real *, integer
*, real *, integer *), slaset_(char *, integer *, integer
*, real *, real *, real *, integer *), slatms_(integer *,
integer *, char *, integer *, char *, real *, integer *, real *,
real *, integer *, integer *, char *, real *, integer *, real *,
integer *);
real result[6];
extern /* Subroutine */ int serrtz_(char *, integer *), stzrqf_(
integer *, integer *, real *, integer *, real *, integer *),
stzrzf_(integer *, integer *, real *, integer *, real *, real *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKTZ tests STZRQF and STZRZF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) REAL array, dimension (MMAX) */
/* WORK (workspace) REAL array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = slamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
serrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
i__4 = m * n + (mnmin << 1) + (n << 2);
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
if (! dotype[imode]) {
goto L50;
}
/* Do for each type of singular value distribution. */
/* 0: zero matrix */
/* 1: one small singular value */
/* 2: exponential distribution */
mode = imode - 1;
/* Test STZRQF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L20: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRQF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
stzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[1] = stzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = stzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test STZRZF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRZF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
stzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[4] = srzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = srzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
L50:
;
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if SCHKTZ */
return 0;
} /* schktz_ */
/* Subroutine */ int srqt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *r__, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int sorgrq_(integer *, integer *, integer *, real
*, integer *, real *, real *, 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 */
/* ======= */
/* SRQT02 tests SORGRQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the RQ factorization of an m-by-n matrix A, SRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by SRQT01. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by SGERQF. */
/* See SGERQF for further details. */
/* Q (workspace) REAL array, dimension (LDA,N) */
/* R (workspace) REAL array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) REAL array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) REAL 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( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_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 */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
slacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
slacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)6, (ftnlen)6);
sorgrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
slaset_("Full", k, m, &c_b10, &c_b10, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
slacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
sgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a[*m - *k + 1 +
a_dim1], lda, &q[q_offset], lda, &c_b16, &r__[*m - *k + 1 + (*n -
*m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = slange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = slange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
slaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
ssyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = slansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of SRQT02 */
} /* srqt02_ */
doublereal sqrt12_(integer *m, integer *n, real *a, integer *lda, real *s,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val;
/* Local variables */
integer i__, j, mn, iscl, info;
real anrm;
extern doublereal snrm2_(integer *, real *, integer *), sasum_(integer *,
real *, integer *);
real dummy[1];
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), sgebd2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *), slabad_(
real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), sbdsqr_(char *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *);
real smlnum, nrmsvl;
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQRT12 computes the singular values `svlues' of the upper trapezoid */
/* of A(1:M,1:N) and returns the ratio */
/* || s - svlues||/(||svlues||*eps*max(M,N)) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input) REAL array, dimension (LDA,N) */
/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* S (input) REAL array, dimension (min(M,N)) */
/* The singular values of the matrix A. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
/* max(M,N), M*N+2*MIN( M, N )+4*N). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
ret_val = 0.f;
/* Test that enough workspace is supplied */
/* Computing MAX */
i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
*n) << 1) + (*n << 2);
if (*lwork < max(i__1,i__2)) {
xerbla_("SQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((real) mn <= 0.f) {
return ret_val;
}
nrmsvl = snrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
slaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.f) {
/* Compute SVD of work */
sgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
sbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
slascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.f;
/* L30: */
}
}
/* Compare s and singular values of work */
saxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = sasum_(&mn, &work[*m * *n + 1], &c__1) / (slamch_("Epsilon") * (real) max(*m,*n));
if (nrmsvl != 0.f) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of SQRT12 */
} /* sqrt12_ */
/* Subroutine */ int slatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, integer *isign, real *amagn, real *rcond, real *triang,
integer *idist, integer *iseed, real *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal), sqrt(doublereal);
/* Local variables */
static integer kbeg, isdb, kend, ioff, isde, klen;
static real temp;
static integer i__, k;
static real alpha;
static integer jc, jd;
static real cl, cr;
static integer jr;
static real sl, sr;
extern doublereal slamch_(char *);
static real safmin;
extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
static real sv1, sv2;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK auxiliary 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
=======
SLATM4 generates basic square matrices, which may later be
multiplied by others in order to produce test matrices. It is
intended mainly to be used to test the generalized eigenvalue
routines.
It first generates the diagonal and (possibly) subdiagonal,
according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
It then fills in the upper triangle with random numbers, if TRIANG is
non-zero.
Arguments
=========
ITYPE (input) INTEGER
The "type" of matrix on the diagonal and sub-diagonal.
If ITYPE < 0, then type abs(ITYPE) is generated and then
swapped end for end (A(I,J) := A'(N-J,N-I).) See also
the description of AMAGN and ISIGN.
Special types:
= 0: the zero matrix.
= 1: the identity.
= 2: a transposed Jordan block.
= 3: If N is odd, then a k+1 x k+1 transposed Jordan block
followed by a k x k identity block, where k=(N-1)/2.
If N is even, then k=(N-2)/2, and a zero diagonal entry
is tacked onto the end.
Diagonal types. The diagonal consists of NZ1 zeros, then
k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
specifies the nonzero diagonal entries as follows:
= 4: 1, ..., k
= 5: 1, RCOND, ..., RCOND
= 6: 1, ..., 1, RCOND
= 7: 1, a, a^2, ..., a^(k-1)=RCOND
= 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
= 9: random numbers chosen from (RCOND,1)
= 10: random numbers with distribution IDIST (see SLARND.)
N (input) INTEGER
The order of the matrix.
NZ1 (input) INTEGER
If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
be zero.
NZ2 (input) INTEGER
If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
be zero.
ISIGN (input) INTEGER
= 0: The sign of the diagonal and subdiagonal entries will
be left unchanged.
= 1: The diagonal and subdiagonal entries will have their
sign changed at random.
= 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
Otherwise, with probability 0.5, odd-even pairs of
diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
converted to a 2x2 block by pre- and post-multiplying
by distinct random orthogonal rotations. The remaining
diagonal entries will have their sign changed at random.
AMAGN (input) REAL
The diagonal and subdiagonal entries will be multiplied by
AMAGN.
RCOND (input) REAL
If abs(ITYPE) > 4, then the smallest diagonal entry will be
entry will be RCOND. RCOND must be between 0 and 1.
TRIANG (input) REAL
The entries above the diagonal will be random numbers with
magnitude bounded by TRIANG (i.e., random numbers multiplied
by TRIANG.)
IDIST (input) INTEGER
Specifies the type of distribution to be used to generate a
random matrix.
= 1: UNIFORM( 0, 1 )
= 2: UNIFORM( -1, 1 )
= 3: NORMAL ( 0, 1 )
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The values of ISEED are changed on exit, and can
be used in the next call to SLATM4 to continue the same
random number sequence.
Note: ISEED(4) should be odd, for the random number generator
used at present.
A (output) REAL array, dimension (LDA, N)
Array to be computed.
LDA (input) INTEGER
Leading dimension of A. Must be at least 1 and at least N.
=====================================================================
Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
slaset_("Full", n, n, &c_b3, &c_b3, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* |ITYPE| = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L20: */
}
goto L220;
/* |ITYPE| = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* |ITYPE| = 3: Transposed Jordan block, followed by the identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L70: */
}
goto L220;
/* |ITYPE| = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = (real) (jd - *nz1);
/* L90: */
}
goto L220;
/* |ITYPE| = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = *rcond;
/* L110: */
}
a_ref(kbeg, kbeg) = 1.f;
goto L220;
/* |ITYPE| = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L130: */
}
a_ref(kend, kend) = *rcond;
goto L220;
/* |ITYPE| = 7: Exponentially distributed D values: */
L140:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
d__1 = (doublereal) (*rcond);
d__2 = (doublereal) (1.f / (real) (klen - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
a_ref(*nz1 + i__, *nz1 + i__) = pow_ri(&alpha, &i__2);
/* L150: */
}
}
goto L220;
/* |ITYPE| = 8: Arithmetically distributed D values: */
L160:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
alpha = (1.f - *rcond) / (real) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
a_ref(*nz1 + i__, *nz1 + i__) = (real) (klen - i__) * alpha +
*rcond;
/* L170: */
}
}
goto L220;
/* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = exp(alpha * slaran_(&iseed[1]));
/* L190: */
}
goto L220;
/* |ITYPE| = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = slarnd_(idist, &iseed[1]);
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = *amagn * a_ref(jd, jd);
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = *amagn * a_ref(jd + 1, jd);
/* L240: */
}
/* If ISIGN = 1 or 2, assign random signs to diagonal and
subdiagonal */
if (*isign > 0) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
if (a_ref(jd, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd, jd) = -a_ref(jd, jd);
}
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
if (a_ref(jd + 1, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd + 1, jd) = -a_ref(jd + 1, jd);
}
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
temp = a_ref(jd, jd);
a_ref(jd, jd) = a_ref(kbeg + kend - jd, kbeg + kend - jd);
a_ref(kbeg + kend - jd, kbeg + kend - jd) = temp;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
temp = a_ref(jd + 1, jd);
a_ref(jd + 1, jd) = a_ref(*n + 1 - jd, *n - jd);
a_ref(*n + 1 - jd, *n - jd) = temp;
/* L280: */
}
}
/* If ISIGN = 2, and no subdiagonals already, then apply
random rotations to make 2x2 blocks. */
if (*isign == 2 && *itype != 2 && *itype != 3) {
safmin = slamch_("S");
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; jd += 2) {
if (slaran_(&iseed[1]) > .5f) {
/* Rotation on left. */
cl = slaran_(&iseed[1]) * 2.f - 1.f;
sl = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cl;
/* Computing 2nd power */
r__4 = sl;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cl *= temp;
sl *= temp;
/* Rotation on right. */
cr = slaran_(&iseed[1]) * 2.f - 1.f;
sr = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cr;
/* Computing 2nd power */
r__4 = sr;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cr *= temp;
sr *= temp;
/* Apply */
sv1 = a_ref(jd, jd);
sv2 = a_ref(jd + 1, jd + 1);
a_ref(jd, jd) = cl * cr * sv1 + sl * sr * sv2;
a_ref(jd + 1, jd) = -sl * cr * sv1 + cl * sr * sv2;
a_ref(jd, jd + 1) = -cl * sr * sv1 + sl * cr * sv2;
a_ref(jd + 1, jd + 1) = sl * sr * sv1 + cl * cr * sv2;
}
/* L290: */
}
}
}
/* Fill in upper triangle (except for 2x2 blocks) */
if (*triang != 0.f) {
if (*isign != 2 || *itype == 2 || *itype == 3) {
ioff = 1;
} else {
ioff = 2;
i__1 = *n - 1;
for (jr = 1; jr <= i__1; ++jr) {
if (a_ref(jr + 1, jr) == 0.f) {
a_ref(jr, jr + 1) = *triang * slarnd_(idist, &iseed[1]);
}
/* L300: */
}
}
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - ioff;
for (jr = 1; jr <= i__2; ++jr) {
a_ref(jr, jc) = *triang * slarnd_(idist, &iseed[1]);
/* L310: */
}
/* L320: */
}
}
return 0;
/* End of SLATM4 */
} /* slatm4_ */
/* Subroutine */ int sdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
real *e, real *b, real *x, real *xact, real *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVPT tests SPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) REAL array, dimension (NMAX*2) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[i__] = a[ia];
e[i__] = a[ia + 1];
ia += 2;
/* L20: */
}
if (n > 0) {
d__[n] = a[ia];
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
slarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + dabs(e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
1], dabs(r__2));
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
dabs(r__3));
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
sscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1] = z__[2];
}
} else if (izero == n) {
e[n - 1] = z__[0];
d__[n] = z__[1];
} else {
e[izero - 1] = z__[0];
d__[izero] = z__[1];
e[izero] = z__[2];
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1];
e[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
z__[0] = e[n - 1];
e[n - 1] = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
z__[0] = e[izero - 1];
z__[2] = e[izero];
e[izero - 1] = 0.f;
e[izero] = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
&b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slanst_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use SPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test SPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from SPTSV . */
if (info != izero) {
alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
1], &lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test SPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
e[n + i__] = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SPTSVX. */
s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &info);
/* Check the error code from SPTSVX. */
if (info != izero) {
alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPT */
} /* sdrvpt_ */
/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt,
integer *k, real *difl, real *difr, real *z__, real *poles, integer *
givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum,
real *c__, real *s, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, i__1, i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf,
vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1;
real beta;
integer idxq, nlvl;
real alpha;
integer inode, ndiml, ndimr, idxqi, itemp, sqrei;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slasd6_(integer *, integer *, integer *, integer *,
real *, real *, real *, real *, real *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, real *, integer *, real *, real *, real *, integer *,
integer *);
integer nwork1, nwork2;
extern /* Subroutine */ int xerbla_(char *, integer *), slasdq_(
char *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *), slasdt_(integer *, integer
*, integer *, integer *, integer *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *);
integer smlszp;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Using a divide and conquer approach, SLASDA computes the singular */
/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */
/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */
/* algorithm computes the singular values in the SVD B = U * S * VT. */
/* The orthogonal matrices U and VT are optionally computed in */
/* compact form. */
/* A related subroutine, SLASD0, computes the singular values and */
/* the singular vectors in explicit form. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed */
/* in compact form, as follows */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors of upper bidiagonal */
/* matrix in compact form. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The row dimension of the upper bidiagonal matrix. This is */
/* also the dimension of the main diagonal array D. */
/* SQRE (input) INTEGER */
/* Specifies the column dimension of the bidiagonal matrix. */
/* = 0: The bidiagonal matrix has column dimension M = N; */
/* = 1: The bidiagonal matrix has column dimension M = N + 1. */
/* D (input/output) REAL array, dimension ( N ) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit D, if INFO = 0, contains its singular values. */
/* E (input) REAL array, dimension ( M-1 ) */
/* Contains the subdiagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* U (output) REAL array, */
/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */
/* singular vector matrices of all subproblems at the bottom */
/* level. */
/* LDU (input) INTEGER, LDU = > N. */
/* The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */
/* GIVNUM, and Z. */
/* VT (output) REAL array, */
/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */
/* singular vector matrices of all subproblems at the bottom */
/* level. */
/* K (output) INTEGER array, dimension ( N ) */
/* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */
/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */
/* secular equation on the computation tree. */
/* DIFL (output) REAL array, dimension ( LDU, NLVL ), */
/* where NLVL = floor(log_2 (N/SMLSIZ))). */
/* DIFR (output) REAL array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */
/* dimension ( N ) if ICOMPQ = 0. */
/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */
/* record distances between singular values on the I-th */
/* level and singular values on the (I -1)-th level, and */
/* DIFR(1:N, 2 * I ) contains the normalizing factors for */
/* the right singular vector matrix. See SLASD8 for details. */
/* Z (output) REAL array, */
/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */
/* dimension ( N ) if ICOMPQ = 0. */
/* The first K elements of Z(1, I) contain the components of */
/* the deflation-adjusted updating row vector for subproblems */
/* on the I-th level. */
/* POLES (output) REAL array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */
/* POLES(1, 2*I) contain the new and old singular values */
/* involved in the secular equations on the I-th level. */
/* GIVPTR (output) INTEGER array, */
/* dimension ( N ) if ICOMPQ = 1, and not referenced if */
/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */
/* the number of Givens rotations performed on the I-th */
/* problem on the computation tree. */
/* GIVCOL (output) INTEGER array, */
/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */
/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */
/* of Givens rotations performed on the I-th level on the */
/* computation tree. */
/* LDGCOL (input) INTEGER, LDGCOL = > N. */
/* The leading dimension of arrays GIVCOL and PERM. */
/* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL ) */
/* if ICOMPQ = 1, and not referenced */
/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */
/* permutations done on the I-th level of the computation tree. */
/* GIVNUM (output) REAL array, */
/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */
/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */
/* values of Givens rotations performed on the I-th level on */
/* the computation tree. */
/* C (output) REAL array, */
/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */
/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */
/* C( I ) contains the C-value of a Givens rotation related to */
/* the right null space of the I-th subproblem. */
/* S (output) REAL array, dimension ( N ) if */
/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */
/* and the I-th subproblem is not square, on exit, S( I ) */
/* contains the S-value of a Givens rotation related to */
/* the right null space of the I-th subproblem. */
/* WORK (workspace) REAL array, dimension */
/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */
/* IWORK (workspace) INTEGER array, dimension (7*N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
givnum_dim1 = *ldu;
givnum_offset = 1 + givnum_dim1;
givnum -= givnum_offset;
poles_dim1 = *ldu;
poles_offset = 1 + poles_dim1;
poles -= poles_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
difr_dim1 = *ldu;
difr_offset = 1 + difr_dim1;
difr -= difr_offset;
difl_dim1 = *ldu;
difl_offset = 1 + difl_dim1;
difl -= difl_offset;
vt_dim1 = *ldu;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--k;
--givptr;
perm_dim1 = *ldgcol;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1;
givcol -= givcol_offset;
--c__;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
} else if (*ldu < *n + *sqre) {
*info = -8;
} else if (*ldgcol < *n) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLASDA", &i__1);
return 0;
}
m = *n + *sqre;
/* If the input matrix is too small, call SLASDQ to find the SVD. */
if (*n <= *smlsiz) {
if (*icompq == 0) {
slasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
work[1], info);
} else {
slasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
info);
}
return 0;
}
/* Book-keeping and set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
ncc = 0;
nru = 0;
smlszp = *smlsiz + 1;
vf = 1;
vl = vf + m;
nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp;
slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* for the nodes on bottom level of the tree, solve */
/* their subproblems by SLASDQ. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node */
/* NL : number of rows of left subproblem */
/* NR : number of rows of right subproblem */
/* NLF: starting row of the left subproblem */
/* NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
idxqi = idxq + nlf - 2;
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
sqrei = 1;
if (*icompq == 0) {
slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
slasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info);
itemp = nwork1 + nl * smlszp;
scopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
scopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
slaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu);
slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
ldu);
slasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
u_dim1], ldu, &work[nwork1], info);
scopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1);
scopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1)
;
}
if (*info != 0) {
return 0;
}
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L10: */
}
if (i__ == nd && *sqre == 0) {
sqrei = 0;
} else {
sqrei = 1;
}
idxqi += nlp1;
vfi += nlp1;
vli += nlp1;
nrp1 = nr + sqrei;
if (*icompq == 0) {
slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
slasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info);
itemp = nwork1 + (nrp1 - 1) * smlszp;
scopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
scopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
slaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu);
slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
ldu);
slasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
u_dim1], ldu, &work[nwork1], info);
scopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1);
scopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1)
;
}
if (*info != 0) {
return 0;
}
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
j = pow_ii(&c__2, &nlvl);
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on */
/* the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
if (i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
idxqi = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
if (*icompq == 0) {
slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info);
} else {
--j;
slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf +
lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 *
givcol_dim1], ldgcol, &givnum[nlf + lvl2 *
givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], &
difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 *
difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j],
&s[j], &work[nwork1], &iwork[iwk], info);
}
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of SLASDA */
} /* slasda_ */
/* Subroutine */ int spteqr_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real c__[1] /* was [1][1] */;
static integer i__;
extern logical lsame_(char *, char *);
static real vt[1] /* was [1][1] */;
extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
char *, integer *, integer *, real *, real *, real *, integer *), sbdsqr_(char *, integer *, integer *, integer *, integer
*, real *, real *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *);
static integer icompz;
extern /* Subroutine */ int spttrf_(integer *, real *, real *, integer *);
static integer nru;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- 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
October 31, 1999
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
Purpose
=======
SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
symmetric positive definite tridiagonal matrix by first factoring the
matrix using SPTTRF, and then calling SBDSQR to compute the singular
values of the bidiagonal factor.
This routine computes the eigenvalues of the positive definite
tridiagonal matrix to high relative accuracy. This means that if the
eigenvalues range over many orders of magnitude in size, then the
small eigenvalues and corresponding eigenvectors will be computed
more accurately than, for example, with the standard QR method.
The eigenvectors of a full or band symmetric positive definite matrix
can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
reduce this matrix to tridiagonal form. (The reduction to tridiagonal
form, however, may preclude the possibility of obtaining high
relative accuracy in the small eigenvalues of the original matrix, if
these eigenvalues range over many orders of magnitude.)
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'V': Compute eigenvectors of original symmetric
matrix also. Array Z contains the orthogonal
matrix used to reduce the original matrix to
tridiagonal form.
= 'I': Compute eigenvectors of tridiagonal matrix also.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the tridiagonal
matrix.
On normal exit, D contains the eigenvalues, in descending
order.
E (input/output) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) REAL array, dimension (LDZ, N)
On entry, if COMPZ = 'V', the orthogonal matrix used in the
reduction to tridiagonal form.
On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
original symmetric matrix;
if COMPZ = 'I', the orthonormal eigenvectors of the
tridiagonal matrix.
If INFO > 0 on exit, Z contains the eigenvectors associated
with only the stored eigenvalues.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
COMPZ = 'V' or 'I', LDZ >= max(1,N).
WORK (workspace) REAL array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, and i is:
<= N the Cholesky factorization of the matrix could
not be performed because the i-th principal minor
was not positive definite.
> N the SVD algorithm failed to converge;
if INFO = N+i, i off-diagonal elements of the
bidiagonal factor did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz > 0) {
z___ref(1, 1) = 1.f;
}
return 0;
}
if (icompz == 2) {
slaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
}
/* Call SPTTRF to factor the matrix. */
latime_1.ops = latime_1.ops + *n * 5 - 4;
spttrf_(n, &d__[1], &e[1], info);
if (*info != 0) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(d__[i__]);
/* L10: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] *= d__[i__];
/* L20: */
}
/* Call SBDSQR to compute the singular values/vectors of the
bidiagonal factor. */
if (icompz > 0) {
nru = *n;
} else {
nru = 0;
}
sbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
z_offset], ldz, c__, &c__1, &work[1], info);
/* Square the singular values. */
if (*info == 0) {
latime_1.ops += *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] *= d__[i__];
/* L30: */
}
} else {
*info = *n + *info;
}
return 0;
/* End of SPTEQR */
} /* spteqr_ */
/* Subroutine */ int sort01_(char *rowcol, integer *m, integer *n, real *u,
integer *ldu, real *work, integer *lwork, real *resid)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, k;
real eps, tmp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
integer mnmin;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
integer ldwork;
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
char transu[1];
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORT01 checks that the matrix U is orthogonal by computing the ratio */
/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* Alternatively, if there isn't sufficient workspace to form */
/* I - U*U' or I - U'*U, the ratio is computed as */
/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
/* or */
/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* where EPS is the machine precision. ROWCOL is used only if m = n; */
/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
/* assumed to be 'R'. */
/* Arguments */
/* ========= */
/* ROWCOL (input) CHARACTER */
/* Specifies whether the rows or columns of U should be checked */
/* for orthogonality. Used only if M = N. */
/* = 'R': Check for orthogonal rows of U */
/* = 'C': Check for orthogonal columns of U */
/* M (input) INTEGER */
/* The number of rows of the matrix U. */
/* N (input) INTEGER */
/* The number of columns of the matrix U. */
/* U (input) REAL array, dimension (LDU,N) */
/* The orthogonal matrix U. U is checked for orthogonal columns */
/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M). */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. For best performance, LWORK */
/* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if */
/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
/* RESID (output) REAL */
/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
/* Function Body */
*resid = 0.f;
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return 0;
}
eps = slamch_("Precision");
if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
*(unsigned char *)transu = 'N';
k = *n;
} else {
*(unsigned char *)transu = 'T';
k = *m;
}
mnmin = min(*m,*n);
if ((mnmin + 1) * mnmin <= *lwork) {
ldwork = mnmin;
} else {
ldwork = 0;
}
if (ldwork > 0) {
/* Compute I - U*U' or I - U'*U. */
slaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
ssyrk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b8,
&work[1], &ldwork);
/* Compute norm( I - U*U' ) / ( K * EPS ) . */
*resid = slansy_("1", "Upper", &mnmin, &work[1], &ldwork, &work[
ldwork * mnmin + 1]);
*resid = *resid / (real) k / eps;
} else if (*(unsigned char *)transu == 'T') {
/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp = 0.f;
} else {
tmp = 1.f;
}
tmp -= sdot_(m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = dabs(tmp);
*resid = dmax(r__1,r__2);
/* L10: */
}
/* L20: */
}
*resid = *resid / (real) (*m) / eps;
} else {
/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
if (i__ != j) {
tmp = 0.f;
} else {
tmp = 1.f;
}
tmp -= sdot_(n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
/* Computing MAX */
r__1 = *resid, r__2 = dabs(tmp);
*resid = dmax(r__1,r__2);
/* L30: */
}
/* L40: */
}
*resid = *resid / (real) (*n) / eps;
}
return 0;
/* End of SORT01 */
} /* sort01_ */
