/* Subroutine */ int derrhs_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits\002,\002 (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublereal a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
integer i__, j, m;
doublereal s[3], w[28];
char c2[2];
doublereal wi[3];
integer nt;
doublereal vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3];
integer ihi, ilo;
logical sel[3];
doublereal tau[3];
integer info;
extern /* Subroutine */ int dgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dgebal_(char *, integer *, doublereal
*, integer *, integer *, integer *, doublereal *, integer *), dgehrd_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
integer ifaill[3], ifailr[3];
extern /* Subroutine */ int dhsein_(char *, char *, char *, logical *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *), dormhr_(char *, char *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 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 .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRHS tests the error exits for DGEBAK, SGEBAL, SGEHRD, DORGHR, */
/* DORMHR, DHSEQR, SHSEIN, and DTREVC. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 3; ++j) {
for (i__ = 1; i__ <= 3; ++i__) {
a[i__ + j * 3 - 4] = 1. / (doublereal) (i__ + j);
/* L10: */
}
wi[j - 1] = (doublereal) j;
sel[j - 1] = TRUE_;
/* L20: */
}
infoc_1.ok = TRUE_;
nt = 0;
/* Test error exits of the nonsymmetric eigenvalue routines. */
if (lsamen_(&c__2, c2, "HS")) {
/* DGEBAL */
s_copy(srnamc_1.srnamt, "DGEBAL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 3;
/* DGEBAK */
s_copy(srnamc_1.srnamt, "DGEBAK", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* DGEHRD */
s_copy(srnamc_1.srnamt, "DGEHRD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* DORGHR */
s_copy(srnamc_1.srnamt, "DORGHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* DORMHR */
s_copy(srnamc_1.srnamt, "DORMHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__2, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__2, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 16;
/* DHSEQR */
s_copy(srnamc_1.srnamt, "DHSEQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dhseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dhseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dhseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dhseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dhseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dhseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dhseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dhseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dhseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* DHSEIN */
s_copy(srnamc_1.srnamt, "DHSEIN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dhsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dhsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dhsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dhsein_("R", "N", "N", sel, &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dhsein_("R", "N", "N", sel, &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__2, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dhsein_("L", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dhsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
dhsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__2, &c__1, &m, w, ifaill, ifailr, &info);
chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* DTREVC */
s_copy(srnamc_1.srnamt, "DTREVC", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dtrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dtrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dtrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dtrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dtrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dtrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dtrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
m, w, &info);
chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
}
/* Print a summary line. */
if (infoc_1.ok) {
io___22.ciunit = infoc_1.nout;
s_wsfe(&io___22);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___23.ciunit = infoc_1.nout;
s_wsfe(&io___23);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of DERRHS */
} /* derrhs_ */
/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *
a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,
integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
/* Local variables */
integer i__, k;
doublereal r__, cs, sn;
integer ihi;
doublereal scl;
integer ilo;
doublereal dum[1], eps;
integer ibal;
char side[1];
doublereal anrm;
integer ierr, itau;
integer iwrk, nout;
logical scalea;
doublereal cscale;
logical select[1];
doublereal bignum;
integer minwrk, maxwrk;
logical wantvl;
doublereal smlnum;
integer hswork;
logical lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGEEV computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* 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). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION 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,3*N), and */
/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
/* performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements i+1:N of WR and WI contain eigenvalues which */
/* have converged. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
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 */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
/* 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. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
n, &c__0);
if (wantvl) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"DORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
hswork = (integer) work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else if (wantvr) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"DORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = (integer) work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else {
minwrk = *n * 3;
dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = (integer) work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (Workspace: need N) */
ibal = 1;
dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vl[vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 4*N) */
dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (Workspace: need N) */
dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (Workspace: need N) */
dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEEV */
} /* dgeev_ */
/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *
a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,
integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,
integer *lwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGEEV computes for an N-by-N real nonsymmetric matrix A, the
eigenvalues and, optionally, the left and/or right eigenvectors.
The right eigenvector v(j) of A satisfies
A * v(j) = lambda(j) * v(j)
where lambda(j) is its eigenvalue.
The left eigenvector u(j) of A satisfies
u(j)**H * A = lambda(j) * u(j)**H
where u(j)**H denotes the conjugate transpose of u(j).
The computed eigenvectors are normalized to have Euclidean norm
equal to 1 and largest component real.
Arguments
=========
JOBVL (input) CHARACTER*1
= 'N': left eigenvectors of A are not computed;
= 'V': left eigenvectors of A are computed.
JOBVR (input) CHARACTER*1
= 'N': right eigenvectors of A are not computed;
= 'V': right eigenvectors of A are computed.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the N-by-N matrix A.
On exit, A has been overwritten.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
WR and WI contain the real and imaginary parts,
respectively, of the computed eigenvalues. Complex
conjugate pairs of eigenvalues appear consecutively
with the eigenvalue having the positive imaginary part
first.
VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order
as their eigenvalues.
If JOBVL = 'N', VL is not referenced.
If the j-th eigenvalue is real, then u(j) = VL(:,j),
the j-th column of VL.
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).
LDVL (input) INTEGER
The leading dimension of the array VL. LDVL >= 1; if
JOBVL = 'V', LDVL >= N.
VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order
as their eigenvalues.
If JOBVR = 'N', VR is not referenced.
If the j-th eigenvalue is real, then v(j) = VR(:,j),
the j-th column of VR.
If the j-th and (j+1)-st eigenvalues form a complex
conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
v(j+1) = VR(:,j) - i*VR(:,j+1).
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1; if
JOBVR = 'V', LDVR >= N.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,3*N), and
if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
performance, LWORK must generally be larger.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the QR algorithm failed to compute all the
eigenvalues, and no eigenvectors have been computed;
elements i+1:N of WR and WI contain eigenvalues which
have converged.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__4 = 4;
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ibal;
static char side[1];
static integer maxb;
static doublereal anrm;
static integer ierr, itau;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer iwrk, nout;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i, k;
static doublereal r;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
dgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
static doublereal cs;
static logical scalea;
extern doublereal dlamch_(char *);
static doublereal cscale;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), xerbla_(char *, integer *);
static logical select[1];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static doublereal bignum;
extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *);
static integer minwrk, maxwrk;
static logical wantvl;
static doublereal smlnum;
static integer hswork;
static logical wantvr;
static integer ihi;
static doublereal scl;
static integer ilo;
static doublereal dum[1], eps;
#define DUM(I) dum[(I)]
#define WR(I) wr[(I)-1]
#define WI(I) wi[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
*info = 0;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
/* 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.
HSWORK refers to the workspace preferred by DHSEQR, as
calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
the worst case.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0, 6L, 1L);
if (! wantvl && ! wantvr) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "EN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "EN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *n +
hswork;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = 1, i__2 = *n << 2;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "DOR"
"GHR", " ", n, &c__1, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "SV", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "SV", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *n +
hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
}
WORK(1) = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &A(1,1), lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &A(1,1), lda, &
ierr);
}
/* Balance the matrix
(Workspace: need N) */
ibal = 1;
dgebal_("B", n, &A(1,1), lda, &ilo, &ihi, &WORK(ibal), &ierr);
/* Reduce to upper Hessenberg form
(Workspace: need 3*N, prefer 2*N+N*NB) */
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &A(1,1), lda, &WORK(itau), &WORK(iwrk), &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors
Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
dlacpy_("L", n, n, &A(1,1), lda, &VL(1,1), ldvl);
/* Generate orthogonal matrix in VL
(Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &VL(1,1), ldvl, &WORK(itau), &WORK(iwrk),
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL
(Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &A(1,1), lda, &WR(1), &WI(1), &
VL(1,1), ldvl, &WORK(iwrk), &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors
Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
dlacpy_("F", n, n, &VL(1,1), ldvl, &VR(1,1), ldvr)
;
}
} else if (wantvr) {
/* Want right eigenvectors
Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
dlacpy_("L", n, n, &A(1,1), lda, &VR(1,1), ldvr);
/* Generate orthogonal matrix in VR
(Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &VR(1,1), ldvr, &WORK(itau), &WORK(iwrk),
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR
(Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &A(1,1), lda, &WR(1), &WI(1), &
VR(1,1), ldvr, &WORK(iwrk), &i__1, info);
} else {
/* Compute eigenvalues only
(Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("E", "N", n, &ilo, &ihi, &A(1,1), lda, &WR(1), &WI(1), &
VR(1,1), ldvr, &WORK(iwrk), &i__1, info);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors
(Workspace: need 4*N) */
dtrevc_(side, "B", select, n, &A(1,1), lda, &VL(1,1), ldvl,
&VR(1,1), ldvr, n, &nout, &WORK(iwrk), &ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors
(Workspace: need N) */
dgebak_("B", "L", n, &ilo, &ihi, &WORK(ibal), n, &VL(1,1), ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real
*/
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (WI(i) == 0.) {
scl = 1. / dnrm2_(n, &VL(1,i), &c__1);
dscal_(n, &scl, &VL(1,i), &c__1);
} else if (WI(i) > 0.) {
d__1 = dnrm2_(n, &VL(1,i), &c__1);
d__2 = dnrm2_(n, &VL(1,i+1), &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &VL(1,i), &c__1);
dscal_(n, &scl, &VL(1,i+1), &c__1);
i__2 = *n;
for (k = 1; k <= *n; ++k) {
/* Computing 2nd power */
d__1 = VL(k,i);
/* Computing 2nd power */
d__2 = VL(k,i+1);
WORK(iwrk + k - 1) = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &WORK(iwrk), &c__1);
dlartg_(&VL(k,i), &VL(k,i+1), &cs,
&sn, &r);
drot_(n, &VL(1,i), &c__1, &VL(1,i+1), &c__1, &cs, &sn);
VL(k,i+1) = 0.;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors
(Workspace: need N) */
dgebak_("B", "R", n, &ilo, &ihi, &WORK(ibal), n, &VR(1,1), ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real
*/
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (WI(i) == 0.) {
scl = 1. / dnrm2_(n, &VR(1,i), &c__1);
dscal_(n, &scl, &VR(1,i), &c__1);
} else if (WI(i) > 0.) {
d__1 = dnrm2_(n, &VR(1,i), &c__1);
d__2 = dnrm2_(n, &VR(1,i+1), &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &VR(1,i), &c__1);
dscal_(n, &scl, &VR(1,i+1), &c__1);
i__2 = *n;
for (k = 1; k <= *n; ++k) {
/* Computing 2nd power */
d__1 = VR(k,i);
/* Computing 2nd power */
d__2 = VR(k,i+1);
WORK(iwrk + k - 1) = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &WORK(iwrk), &c__1);
dlartg_(&VR(k,i), &VR(k,i+1), &cs,
&sn, &r);
drot_(n, &VR(1,i), &c__1, &VR(1,i+1), &c__1, &cs, &sn);
VR(k,i+1) = 0.;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &WR(*info +
1), &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &WI(*info +
1), &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &WR(1),
n, &ierr);
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &WI(1),
n, &ierr);
}
}
WORK(1) = (doublereal) maxwrk;
return 0;
/* End of DGEEV */
} /* dgeev_ */
/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n,
doublereal *a, integer *lda, integer *sdim, doublereal *wr,
doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,
integer *lwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s;
integer i1, i2, ip, ihi, ilo;
doublereal dum[1], eps, sep;
integer ibal;
doublereal anrm;
integer idum[1], ierr, itau, iwrk, inxt, icond, ieval;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical cursl;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
dgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
logical lst2sl, scalea;
extern doublereal dlamch_(char *);
doublereal cscale;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
doublereal bignum;
extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, integer *);
logical lastsl;
integer minwrk, maxwrk;
doublereal smlnum;
integer hswork;
logical wantst, lquery, wantvs;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEES computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* real Schur form so that selected eigenvalues are at the top left. */
/* The leading columns of Z then form an orthonormal basis for the */
/* invariant subspace corresponding to the selected eigenvalues. */
/* A matrix is in real Schur form if it is upper quasi-triangular with */
/* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the */
/* form */
/* [ a b ] */
/* [ c a ] */
/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
/* SELECT(WR(j),WI(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 a selected complex eigenvalue may no longer */
/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned); in this */
/* case INFO is set to N+2 (see INFO below). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten by its real Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELECT is true. (Complex conjugate */
/* pairs for which SELECT is true for either */
/* eigenvalue count as 2.) */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues in the same order */
/* that they appear on the diagonal of the output Schur form T. */
/* Complex conjugate pairs of eigenvalues will appear */
/* consecutively with the eigenvalue having the positive */
/* imaginary part first. */
/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1; if */
/* JOBVS = 'V', LDVS >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,3*N). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* 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. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the matrix which reduces A */
/* to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--bwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -11;
}
/* 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. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
n, &c__0);
minwrk = *n * 3;
dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = (integer) work[1];
if (! wantvs) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"DORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
}
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEES ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (Workspace: need N) */
ibal = 1;
dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
/* L10: */
}
/* Reorder eigenvalues and transform Schur vectors */
/* (Workspace: none needed) */
i__1 = *lwork - iwrk + 1;
dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1,
idum, &c__1, &icond);
if (icond > 0) {
*info = *n + icond;
}
}
if (wantvs) {
/* Undo balancing */
/* (Workspace: need N) */
dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
/* Computing MAX */
i__3 = ilo - 1;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], &i__2, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.) {
inxt = i__ + 1;
} else {
if (a[i__ + 1 + i__ * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
} else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + (
i__ + 1) * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
if (i__ > 1) {
i__2 = i__ - 1;
dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
if (wantvs) {
dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__
+ 1) * vs_dim1 + 1], &c__1);
}
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.;
}
inxt = i__ + 2;
}
L20:
;
}
}
/* Undo scaling for the imaginary part of the eigenvalues */
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.) {
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: */
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEES */
} /* dgees_ */
/**
* <p>Calculates roots of a polynomial.</p>
*
* @param a
* Pointer to polynomial coefficients.
* @param m
* Number of polynomial coefficients stored in <CODE>a</CODE>.
* @param rtr
* Resulting real roots.
* @param rti
* Resulting imaginary roots.
* @return <code>O_K</code> if successful, a (negative) error code otherwise
*/
INT16 dlm_roots(FLOAT64* A, COMPLEX64* Z, INT16 nA) {
INT16 j, k;
integer m = nA;
integer ilo;
integer ihi;
integer info;
integer c__1 = 1;
integer lwork = 0;
char job1[1] = { 'S' };
char job2[1] = { 'E' };
char compz[1] = { 'N' };
#ifdef __MAX_TYPE_32BIT
int sgebal_(char*,integer*,real*,integer*,integer*,integer*,real*,integer*);
int shseqr_(char*,char*,integer*,integer*,integer*,real*,integer*,real*,real*,real*,integer*,real*,integer*,integer*);
#else
int dgebal_(char*,integer*,doublereal*,integer*,integer*,integer*,doublereal*,integer*);
int dhseqr_(char*,char*,integer*,integer*,integer*,doublereal*,integer*,doublereal*,doublereal*,doublereal*,integer*,doublereal*,integer*,integer*);
#endif
#define _H(i,j) *(hess+(j)+(i)*m)
if ((!A) || (!Z)) return NOT_EXEC;
k = 0;
while ((k < m) && (*(A + k) == 0.0)) {
k++;
A++;
}
m -= k;
m--;
if (m <= 0) return NOT_EXEC;
#ifdef __MAX_TYPE_32BIT
real* hess = (real*) dlp_malloc((4*m+m*m)*sizeof(real));
if (!hess) return ERR_MEM;
real* scale = hess + m * m;
real* wr = scale + m;
real* wi = wr + m;
real* work = wi + m;
#else
doublereal* hess=(doublereal*)dlp_malloc((4*m+m*m)*sizeof(doublereal));
if(!hess) return ERR_MEM;
doublereal* scale = hess + m*m;
doublereal* wr = scale + m;
doublereal* wi = wr + m;
doublereal* work = wi + m;
#endif
lwork = m;
for (k = 0; k < m; k++) {
_H(m-1,k) = -A[k + 1] / A[0];
for (j = 0; j < m - 1; j++)
_H(j,k) = ((j == (k - 1)) && (k > 0)) ? 1.0 : 0.0;
}
#ifdef __MAX_TYPE_32BIT
sgebal_(job1, &m, hess, &m, &ilo, &ihi, scale, &info);
shseqr_(job2, compz, &m, &ilo, &ihi, hess, &m, wr, wi, NULL, &c__1, work, &lwork, &info);
#else
dgebal_(job1, &m, hess, &m, &ilo, &ihi, scale, &info);
dhseqr_(job2, compz, &m, &ilo, &ihi, hess, &m, wr, wi, NULL, &c__1, work, &lwork, &info);
#endif
dlp_free(hess);
for (j = 0; j < m; j++) {
Z[j].x = wr[j];
Z[j].y = wi[j];
}
return (info == 0) ? O_K : NOT_EXEC;
#undef _H
}
int dgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, int *n, double *a, int *lda, double *wr,
double *wi, double *vl, int *ldvl, double *vr,
int *ldvr, int *ilo, int *ihi, double *scale,
double *abnrm, double *rconde, double *rcondv, double
*work, int *lwork, int *iwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
double d__1, d__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, k;
double r__, cs, sn;
char job[1];
double scl, dum[1], eps;
char side[1];
double anrm;
int ierr, itau;
extern int drot_(int *, double *, int *,
double *, int *, double *, double *);
int iwrk, nout;
extern double dnrm2_(int *, double *, int *);
extern int dscal_(int *, double *, double *,
int *);
int icond;
extern int lsame_(char *, char *);
extern double dlapy2_(double *, double *);
extern int dlabad_(double *, double *), dgebak_(
char *, char *, int *, int *, int *, double *,
int *, double *, int *, int *),
dgebal_(char *, int *, double *, int *, int *,
int *, double *, int *);
int scalea;
extern double dlamch_(char *);
double cscale;
extern double dlange_(char *, int *, int *, double *,
int *, double *);
extern int dgehrd_(int *, int *, int *,
double *, int *, double *, double *, int *,
int *), dlascl_(char *, int *, int *, double *,
double *, int *, int *, double *, int *,
int *);
extern int idamax_(int *, double *, int *);
extern int dlacpy_(char *, int *, int *,
double *, int *, double *, int *),
dlartg_(double *, double *, double *, double *,
double *), xerbla_(char *, int *);
int select[1];
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
double bignum;
extern int dorghr_(int *, int *, int *,
double *, int *, double *, double *, int *,
int *), dhseqr_(char *, char *, int *, int *, int
*, double *, int *, double *, double *,
double *, int *, double *, int *, int *), dtrevc_(char *, char *, int *, int *,
double *, int *, double *, int *, double *,
int *, int *, int *, double *, int *), dtrsna_(char *, char *, int *, int *, double
*, int *, double *, int *, double *, int *,
double *, double *, int *, int *, double *,
int *, int *, int *);
int minwrk, maxwrk;
int wantvl, wntsnb;
int hswork;
int wntsne;
double smlnum;
int lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEEVX computes for an N-by-N float nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component float. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, i.e. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the float Schur form of the balanced */
/* version of the input matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the float and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues will appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is float, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* 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). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is float, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are int values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) DOUBLE PRECISION 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 SENSE = 'N' or 'E', */
/* LWORK >= MAX(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (2*N-2) */
/* If SENSE = 'N' or 'E', not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of WR */
/* and WI contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < MAX(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* 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. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
dhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = (int) work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = MAX(i__1,i__2);
}
maxwrk = MAX(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = MAX(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = MAX(i__1,i__2);
}
maxwrk = MAX(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "DORGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = MAX(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = MAX(i__1,i__2);
}
maxwrk = MAX(maxwrk,minwrk);
}
work[1] = (double) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
dgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = dlange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired */
/* (Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
dtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
dgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &work[1], &c__1);
dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
dgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &work[1], &c__1);
dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = MAX(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = MAX(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (double) maxwrk;
return 0;
/* End of DGEEVX */
} /* dgeevx_ */
/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, integer *n, doublereal *a, integer *lda, integer *sdim,
doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs,
doublereal *rconde, doublereal *rcondv, doublereal *work, integer *
lwork, integer *iwork, integer *liwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, i1, i2, ip, ihi, ilo;
doublereal dum[1], eps;
integer ibal;
doublereal anrm;
integer ierr, itau, iwrk, lwrk, inxt, icond, ieval;
logical cursl;
integer liwrk;
logical lst2sl, scalea;
doublereal cscale;
doublereal bignum;
logical wantsb;
logical wantse, lastsl;
integer minwrk, maxwrk;
logical wantsn;
doublereal smlnum;
integer hswork;
logical wantst, lquery, wantsv, wantvs;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGEESX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* real Schur form so that selected eigenvalues are at the top left; */
/* computes a reciprocal condition number for the average of the */
/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
/* number for the right invariant subspace corresponding to the */
/* selected eigenvalues (RCONDV). The leading columns of Z form an */
/* orthonormal basis for this invariant subspace. */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
/* these quantities are called s and sep respectively). */
/* A real matrix is in real Schur form if it is upper quasi-triangular */
/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
/* the form */
/* [ a b ] */
/* [ c a ] */
/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
/* complex conjugate pair of eigenvalues is selected, then both */
/* are. Note that a selected complex eigenvalue may no longer */
/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned); in this */
/* case INFO may be set to N+3 (see INFO below). */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for average of selected eigenvalues only; */
/* = 'V': Computed for selected right invariant subspace only; */
/* = 'B': Computed for both. */
/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A is overwritten by its real Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELECT is true. (Complex conjugate */
/* pairs for which SELECT is true for either */
/* eigenvalue count as 2.) */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the real and imaginary parts, respectively, */
/* of the computed eigenvalues, in the same order that they */
/* appear on the diagonal of the output Schur form T. Complex */
/* conjugate pairs of eigenvalues appear consecutively with the */
/* eigenvalue having the positive imaginary part first. */
/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1, and if */
/* JOBVS = 'V', LDVS >= N. */
/* RCONDE (output) DOUBLE PRECISION */
/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
/* condition number for the average of the selected eigenvalues. */
/* Not referenced if SENSE = 'N' or 'V'. */
/* RCONDV (output) DOUBLE PRECISION */
/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
/* condition number for the selected right invariant subspace. */
/* Not referenced if SENSE = 'N' or 'E'. */
/* WORK (workspace/output) DOUBLE PRECISION 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,3*N). */
/* Also, if SENSE = 'E' or 'V' or 'B', */
/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
/* selected eigenvalues computed by this routine. Note that */
/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */
/* 'B' this may not be large enough. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates upper bounds on the optimal sizes of the */
/* arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are 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. */
/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
/* may not be large enough. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates upper bounds on the optimal sizes of */
/* the arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are 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. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the transformation which */
/* reduces A to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--iwork;
--bwork;
/* Function Body */
*info = 0;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
lquery = *lwork == -1 || *liwork == -1;
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "RWorkspace:" describe the */
/* minimal amount of real workspace needed at that point in the */
/* code, as well as the preferred amount for good performance. */
/* IWorkspace refers to integer workspace. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case. */
/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
/* depends on SDIM, which is computed by the routine DTRSEN later */
/* in the code.) */
if (*info == 0) {
liwrk = 1;
if (*n == 0) {
minwrk = 1;
lwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
n, &c__0);
minwrk = *n * 3;
dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = (integer) work[1];
if (! wantvs) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"DORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
}
lwrk = maxwrk;
if (! wantsn) {
/* Computing MAX */
i__1 = lwrk, i__2 = *n + *n * *n / 2;
lwrk = max(i__1,i__2);
}
if (wantsv || wantsb) {
liwrk = *n * *n / 4;
}
}
iwork[1] = liwrk;
work[1] = (doublereal) lwrk;
if (*lwork < minwrk && ! lquery) {
*info = -16;
} else if (*liwork < 1 && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (RWorkspace: need N) */
ibal = 1;
dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS */
/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
}
/* Reorder eigenvalues, transform Schur vectors, and compute */
/* reciprocal condition numbers */
/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
/* otherwise, need N ) */
/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
/* otherwise, need 0 ) */
i__1 = *lwork - iwrk + 1;
dtrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
i__1, &iwork[1], liwork, &icond);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (icond == -15) {
/* Not enough real workspace */
*info = -16;
} else if (icond == -17) {
/* Not enough integer workspace */
*info = -18;
} else if (icond > 0) {
/* DTRSEN failed to reorder or to restore standard Schur form */
*info = icond + *n;
}
}
if (wantvs) {
/* Undo balancing */
/* (RWorkspace: need N) */
dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr);
*rcondv = dum[0];
}
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], n, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.) {
inxt = i__ + 1;
} else {
if (a[i__ + 1 + i__ * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
} else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + (
i__ + 1) * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
if (i__ > 1) {
i__2 = i__ - 1;
dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
* vs_dim1 + 1], &c__1);
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.;
}
inxt = i__ + 2;
}
L20:
;
}
}
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.) {
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;
}
}
work[1] = (doublereal) maxwrk;
if (wantsv || wantsb) {
/* Computing MAX */
i__1 = 1, i__2 = *sdim * (*n - *sdim);
iwork[1] = max(i__1,i__2);
} else {
iwork[1] = 1;
}
return 0;
/* End of DGEESX */
} /* dgeesx_ */
/* Subroutine */
int dgees_(char *jobvs, char *sort, L_fp select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s;
integer i1, i2, ip, ihi, ilo;
doublereal dum[1], eps, sep;
integer ibal;
doublereal anrm;
integer idum[1], ierr, itau, iwrk, inxt, icond, ieval;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical cursl;
extern /* Subroutine */
int dlabad_(doublereal *, doublereal *), dgebak_( char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *), dgebal_(char *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *);
logical lst2sl, scalea;
extern doublereal dlamch_(char *);
doublereal cscale;
extern doublereal dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */
int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
doublereal bignum;
extern /* Subroutine */
int dorghr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dhseqr_(char *, char *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *);
logical lastsl;
integer minwrk, maxwrk;
doublereal smlnum;
integer hswork;
logical wantst, lquery, wantvs;
/* -- 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 .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--bwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
if (! wantvs && ! lsame_(jobvs, "N"))
{
*info = -1;
}
else if (! wantst && ! lsame_(sort, "N"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldvs < 1 || wantvs && *ldvs < *n)
{
*info = -11;
}
/* 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. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0)
{
if (*n == 0)
{
minwrk = 1;
maxwrk = 1;
}
else
{
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &c__0);
minwrk = *n * 3;
dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1] , &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = (integer) work[1];
if (! wantvs)
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + hswork; // , expr subst
maxwrk = max(i__1,i__2);
}
else
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "DORGHR", " ", n, &c__1, n, &c_n1); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + hswork; // , expr subst
maxwrk = max(i__1,i__2);
}
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery)
{
*info = -13;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGEES ", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum)
{
scalea = TRUE_;
cscale = smlnum;
}
else if (anrm > bignum)
{
scalea = TRUE_;
cscale = bignum;
}
if (scalea)
{
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (Workspace: need N) */
ibal = 1;
dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &ierr);
if (wantvs)
{
/* Copy Householder vectors to VS */
dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) ;
/* Generate orthogonal matrix in VS */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], &i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0)
{
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0)
{
if (scalea)
{
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, & ierr);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, & ierr);
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
/* L10: */
}
/* Reorder eigenvalues and transform Schur vectors */
/* (Workspace: none needed) */
i__1 = *lwork - iwrk + 1;
dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1, idum, &c__1, &icond);
if (icond > 0)
{
*info = *n + icond;
}
}
if (wantvs)
{
/* Undo balancing */
/* (Workspace: need N) */
dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs, &ierr);
}
if (scalea)
{
/* Undo scaling for the Schur form of A */
dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & ierr);
i__1 = *lda + 1;
dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if (cscale == smlnum)
{
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0)
{
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
/* Computing MAX */
i__3 = ilo - 1;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ 1], &i__2, &ierr);
}
else if (wantst)
{
i1 = 1;
i2 = *n - 1;
}
else
{
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1;
i__ <= i__1;
++i__)
{
if (i__ < inxt)
{
goto L20;
}
if (wi[i__] == 0.)
{
inxt = i__ + 1;
}
else
{
if (a[i__ + 1 + i__ * a_dim1] == 0.)
{
wi[i__] = 0.;
wi[i__ + 1] = 0.;
}
else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + ( i__ + 1) * a_dim1] == 0.)
{
wi[i__] = 0.;
wi[i__ + 1] = 0.;
if (i__ > 1)
{
i__2 = i__ - 1;
dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[( i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1)
{
i__2 = *n - i__ - 1;
dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, & a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
if (wantvs)
{
dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1) * vs_dim1 + 1], &c__1);
}
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.;
}
inxt = i__ + 2;
}
L20:
;
}
}
/* Undo scaling for the imaginary part of the eigenvalues */
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval + 1], &i__2, &ierr);
}
if (wantst && *info == 0)
{
/* Check if reordering successful */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.)
{
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: */
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEES */
}
