/* ----------------------------------------------------------------------- */
/* Subroutine */ int sneupd_(logical *rvec, char *howmny, logical *select,
real *dr, real *di, real *z__, integer *ldz, real *sigmar, real *
sigmai, real *workev, char *bmat, integer *n, char *which, integer *
nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv,
integer *iparam, integer *ipntr, real *workd, real *workl, integer *
lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen
which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
real r__1, r__2;
doublereal d__1;
/* Local variables */
static integer j, k, ih, jj, np;
static real vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static real sep;
static integer irr, wri, wrr, mode;
static real eps23;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer ierr;
static real temp;
static integer iwev;
static char type__[6];
static real temp1;
extern doublereal snrm2_(integer *, real *, integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real conds;
static logical reord;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static integer nconv, iwork[1];
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer ritzi;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *,
integer *, integer *, char *, ftnlen), smout_(integer *, integer *
, integer *, real *, integer *, integer *, char *, ftnlen);
static integer ritzr;
extern /* Subroutine */ int svout_(integer *, integer *, real *, integer *
, char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer *
, real *, real *, integer *);
static integer nconv2;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, ftnlen, ftnlen);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slahqr_(logical *, logical
*, integer *, integer *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *, ftnlen), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, real *, integer *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer
*, real *, real *, real *, real *, real *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.f) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by SNEUPD. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.f;
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: "
"Real part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: "
"Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (real) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[
bounds], &workl[1], &workl[np + 1], (ftnlen)2);
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu"
"pd: Real part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu"
"pd: Imag part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = dmax(r__1,r__2);
jj = workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > nconv) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine slahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by SNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, (
ftnlen)3);
slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H", (ftnlen)41);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imaginary part of the Eigenvalues of H", (ftnlen)
46);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper quasi-triangular "
"matrix ", (ftnlen)42);
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv2, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr, (ftnlen)4, (ftnlen)1);
if (nconv2 < nconv) {
nconv = nconv2;
}
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H--reordered"
, (ftnlen)52);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imag part of the eigenvalues of H--reordered"
, (ftnlen)52);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Quasi-triangular matrix"
" after re-ordering", (ftnlen)49);
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using sorm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) {
sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | strevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = slapy2_(&r__1, &r__2);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &
c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.f) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = slapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &
c__1);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the eigenvector matrix for T", (
ftnlen)48);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr, (ftnlen)5, (ftnlen)11);
strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed SNAUPD into DR and DI | */
/* %------------------------------------------------------% */
scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs(
r__1)) / temp / temp;
/* L50: */
}
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
}
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un"
"transformed real part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un"
"transformed imag part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of untransformed Ritz values.", (ftnlen)
52);
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl >
1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re"
"al parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im"
"ag parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of SNEUPD | */
/* %---------------% */
} /* sneupd_ */
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
char job[1];
real scl, dum[1], eps;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
integer icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEVX computes for an N-by-N real 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 real. */
/* 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) REAL 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 real 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) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real 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) REAL 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) REAL 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, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer 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) REAL 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) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If 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 SHSEQR, 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, "SGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
shseqr_("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) {
shseqr_("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) {
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = 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, "SORGHR",
" ", 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] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("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;
sgehrd_(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';
slacpy_("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;
sorghr_(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;
shseqr_("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';
slacpy_("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';
slacpy_("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;
sorghr_(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;
shseqr_("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;
shseqr_(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 SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
strevc_(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) {
strsna_(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 */
sgebak_(balanc, "L", n, ilo, ihi, &scale[1], 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.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(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.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
sgebak_(balanc, "R", n, ilo, ihi, &scale[1], 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.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(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.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("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);
slascl_("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) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEVX */
} /* sgeevx_ */
/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a,
integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr,
integer *ldvr, real *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;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
integer ihi;
real scl;
integer ilo;
real dum[1], eps;
integer ibal;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
logical wantvl;
real smlnum;
integer hswork;
logical lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEV 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) REAL 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) REAL array, dimension (N) */
/* WI (output) REAL 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) REAL 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) REAL 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) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,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. */
/* ===================================================================== */
/* .. 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;
--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 SHSEQR, 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, "SGEHRD", " ", 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,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
hswork = 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,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = 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;
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = 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] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (Workspace: need N) */
ibal = 1;
sgebal_("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;
sgehrd_(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';
slacpy_("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;
sorghr_(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;
shseqr_("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';
slacpy_("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';
slacpy_("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;
sorghr_(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;
shseqr_("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;
shseqr_("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 SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 4*N) */
strevc_(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) */
sgebak_("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.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(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.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (Workspace: need N) */
sgebak_("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.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(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.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("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);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEV */
} /* sgeev_ */
/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, m, n;
real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */,
re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1],
eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */;
integer ifnd, icmp, iscl, info, lcmp[3], kmin;
real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real sepin[20], vimin, tolin, vrmin;
integer iwork[40];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real witmp[20], wrtmp[20];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
logical select[20];
real bignum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), shseqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, integer *, real *, integer *, integer *)
, strevc_(char *, char *, logical *, integer *, real *, integer *,
real *, integer *, real *, integer *, integer *, integer *, real
*, integer *);
real septmp[20];
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
real smlnum;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, 0, 0 };
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET37 tests STRSNA, a routine for estimating condition numbers of */
/* eigenvalues and/or right eigenvectors of a matrix. */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL array, dimension (3) */
/* Value of the largest test ratio. */
/* RMAX(1) = largest ratio comparing different calls to STRSNA */
/* RMAX(2) = largest error in reciprocal condition */
/* numbers taking their conditioning into account */
/* RMAX(3) = largest error in reciprocal condition */
/* numbers not taking their conditioning into */
/* account (may be larger than RMAX(2)) */
/* LMAX (output) INTEGER array, dimension (3) */
/* LMAX(i) is example number where largest test ratio */
/* RMAX(i) is achieved. Also: */
/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
/* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
/* NINFO(3) = No. of times STRSNA returned INFO nonzero */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
--lmax;
--rmax;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* EPSIN = 2**(-24) = precision to which input data computed */
eps = dmax(eps,5.9605e-8f);
rmax[1] = 0.f;
rmax[2] = 0.f;
rmax[3] = 0.f;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
val[0] = sqrt(smlnum);
val[1] = 1.f;
val[2] = sqrt(bignum);
/* Read input data until N=0. Assume input eigenvalues are sorted */
/* lexicographically (increasing by real part, then decreasing by */
/* imaginary part) */
L10:
io___5.ciunit = *nin;
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___8.ciunit = *nin;
s_rsle(&io___8);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
e_rsle();
/* L30: */
}
tnrm = slange_("M", &n, &n, tmp, &c__20, work);
/* Begin test */
for (iscl = 1; iscl <= 3; ++iscl) {
/* Scale input matrix */
++(*knt);
slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
vmul = val[iscl - 1];
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
/* L40: */
}
if (tnrm == 0.f) {
vmul = 1.f;
}
/* Compute eigenvalues and eigenvectors */
i__1 = 1200 - n;
sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
if (info != 0) {
lmax[1] = *knt;
++ninfo[1];
goto L240;
}
i__1 = n - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
t[i__ + j * 20 - 21] = 0.f;
/* L50: */
}
/* L60: */
}
/* Compute Schur form */
shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
&c__1200, &info);
if (info != 0) {
lmax[2] = *knt;
++ninfo[2];
goto L240;
}
/* Compute eigenvectors */
strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
&n, &m, work, &info);
/* Compute condition numbers */
strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
s, sep, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
/* Sort eigenvalues and condition numbers lexicographically */
/* to compare with inputs */
scopy_(&n, wr, &c__1, wrtmp, &c__1);
scopy_(&n, wi, &c__1, witmp, &c__1);
scopy_(&n, s, &c__1, stmp, &c__1);
scopy_(&n, sep, &c__1, septmp, &c__1);
r__1 = 1.f / vmul;
sscal_(&n, &r__1, septmp, &c__1);
i__1 = n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
vrmin = wrtmp[i__ - 1];
vimin = witmp[i__ - 1];
i__2 = n;
for (j = i__ + 1; j <= i__2; ++j) {
if (wrtmp[j - 1] < vrmin) {
kmin = j;
vrmin = wrtmp[j - 1];
vimin = witmp[j - 1];
}
/* L70: */
}
wrtmp[kmin - 1] = wrtmp[i__ - 1];
witmp[kmin - 1] = witmp[i__ - 1];
wrtmp[i__ - 1] = vrmin;
witmp[i__ - 1] = vimin;
vrmin = stmp[kmin - 1];
stmp[kmin - 1] = stmp[i__ - 1];
stmp[i__ - 1] = vrmin;
vrmin = septmp[kmin - 1];
septmp[kmin - 1] = septmp[i__ - 1];
septmp[i__ - 1] = vrmin;
/* L80: */
}
/* Compare condition numbers for eigenvalues */
/* taking their condition numbers into account */
/* Computing MAX */
r__1 = (real) n * 2.f * eps * tnrm;
v = dmax(r__1,smlnum);
if (tnrm == 0.f) {
v = 1.f;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1]) {
tol = 1.f;
} else {
tol = v / septmp[i__ - 1];
}
if (v > sepin[i__ - 1]) {
tolin = 1.f;
} else {
tolin = v / sepin[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
} else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L90: */
}
/* Compare condition numbers for eigenvectors */
/* taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
tol = septmp[i__ - 1];
} else {
tol = v / stmp[i__ - 1];
}
if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
tolin = sepin[i__ - 1];
} else {
tolin = v / sin__[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
} else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
{
vmax = 1.f / eps;
} else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L100: */
}
/* Compare condition numbers for eigenvalues */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
real) (n << 1) * eps) {
vmax = 1.f;
} else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = sin__[i__ - 1] / stmp[i__ - 1];
} else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] < stmp[i__ - 1]) {
vmax = stmp[i__ - 1] / sin__[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L110: */
}
/* Compare condition numbers for eigenvectors */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
vmax = 1.f;
} else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = sepin[i__ - 1] / septmp[i__ - 1];
} else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] < septmp[i__ - 1]) {
vmax = septmp[i__ - 1] / sepin[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L120: */
}
/* Compute eigenvalue condition numbers only and compare */
vmax = 0.f;
dum[0] = -1.f;
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L130: */
}
/* Compute eigenvector condition numbers only and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L140: */
}
/* Compute all condition numbers using SELECT and compare */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
select[i__ - 1] = TRUE_;
/* L150: */
}
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
/* L160: */
}
/* Compute eigenvalue condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L170: */
}
/* Compute eigenvector condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L180: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
/* Select first real and first complex eigenvalue */
if (wi[0] == 0.f) {
lcmp[0] = 1;
ifnd = 0;
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] == 0.f) {
select[i__ - 1] = FALSE_;
} else {
ifnd = 1;
lcmp[1] = i__;
lcmp[2] = i__ + 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
c__1);
}
/* L190: */
}
if (ifnd == 0) {
icmp = 1;
} else {
icmp = 3;
}
} else {
lcmp[0] = 1;
lcmp[1] = 2;
ifnd = 0;
i__1 = n;
for (i__ = 3; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] != 0.f) {
select[i__ - 1] = FALSE_;
} else {
lcmp[2] = i__;
ifnd = 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
}
/* L200: */
}
if (ifnd == 0) {
icmp = 2;
} else {
icmp = 3;
}
}
/* Compute all selected condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
/* L210: */
}
/* Compute selected eigenvalue condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L220: */
}
/* Compute selected eigenvector condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
/* L230: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
L240:
;
}
goto L10;
/* End of SGET37 */
} /* sget37_ */
/* Subroutine */ int serrhs_(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)";
/* Local variables */
real a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
integer i__, j, m;
real s[3], w[28];
char c2[2];
real wi[3];
integer nt;
real vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3];
integer ihi, ilo;
logical sel[3];
real tau[3];
integer info;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
integer ifaill[3], ifailr[3];
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), shsein_(char *, char *, char *, logical *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *, integer *, real *, integer *,
integer *, integer *), sorghr_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *), shseqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *), strevc_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, 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 */
/* ======= */
/* SERRHS tests the error exits for SGEBAK, SGEBAL, SGEHRD, SORGHR, */
/* SORMHR, SHSEQR, SHSEIN, and STREVC. */
/* 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.f / (real) (i__ + j);
/* L10: */
}
wi[j - 1] = (real) 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")) {
/* SGEBAL */
s_copy(srnamc_1.srnamt, "SGEBAL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 3;
/* SGEBAK */
s_copy(srnamc_1.srnamt, "SGEBAK", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* SGEHRD */
s_copy(srnamc_1.srnamt, "SGEHRD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* SORGHR */
s_copy(srnamc_1.srnamt, "SORGHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* SORMHR */
s_copy(srnamc_1.srnamt, "SORMHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__2, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__2, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 16;
/* SHSEQR */
s_copy(srnamc_1.srnamt, "SHSEQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
shseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
shseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
shseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
shseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
shseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
shseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
shseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* SHSEIN */
s_copy(srnamc_1.srnamt, "SHSEIN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
shsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
shsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
shsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shsein_("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_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
shsein_("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_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
shsein_("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_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
shsein_("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_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
shsein_("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_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* STREVC */
s_copy(srnamc_1.srnamt, "STREVC", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
strevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
strevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
m, w, &info);
chkxer_("STREVC", &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 SERRHS */
} /* serrhs_ */