/* Subroutine */ int serrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error ex\002,\002its ***\002)";
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
real a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16] /*
was [4][4] */;
integer i__, j, m;
real s[4], wi[4];
integer nt;
real wr[4];
logical sel[4];
real sep[4];
integer info, ifst, ilst;
real work[4], scale;
integer iwork[4];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), strexc_(char *, integer *, real *, integer
*, real *, integer *, integer *, integer *, real *, integer *), strsna_(char *, char *, logical *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
integer *, integer *, real *, integer *, integer *, integer *), strsen_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, integer *, integer *, integer *, integer *
), strsyl_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 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 */
/* ======= */
/* SERREC tests the error exits for the routines for eigen- condition */
/* estimation for REAL matrices: */
/* STRSYL, STREXC, STRSNA and STRSEN. */
/* 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 Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 0.f;
b[i__ + (j << 2) - 5] = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (i__ << 2) - 5] = 1.f;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test STRSYL */
s_copy(srnamc_1.srnamt, "STRSYL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
strsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STREXC */
s_copy(srnamc_1.srnamt, "STREXC", (ftnlen)32, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
strexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
strexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STRSNA */
s_copy(srnamc_1.srnamt, "STRSNA", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
strsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test STRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "STRSEN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
strsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__2, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__0, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__3, iwork, &c__2, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("E", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__0, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__4, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
/* Print a summary line. */
if (infoc_1.ok) {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___20.ciunit = infoc_1.nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of SERREC */
} /* serrec_ */
int sgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, int *n, float *a, int *lda, int *sdim, float *wr,
float *wi, float *vs, int *ldvs, float *rconde, float *rcondv, float *
work, int *lwork, int *iwork, int *liwork, int *bwork,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, i1, i2, ip, ihi, ilo;
float dum[1], eps;
int ibal;
float anrm;
int ierr, itau, iwrk, lwrk, inxt, icond, ieval;
extern int lsame_(char *, char *);
int cursl;
int liwrk;
extern int scopy_(int *, float *, int *, float *,
int *), sswap_(int *, float *, int *, float *, int *
);
int lst2sl;
extern int slabad_(float *, float *);
int scalea;
float cscale;
extern int sgebak_(char *, char *, int *, int *,
int *, float *, int *, float *, int *, int *), sgebal_(char *, int *, float *, int *,
int *, int *, float *, int *);
extern double slamch_(char *), slange_(char *, int *,
int *, float *, int *, float *);
extern int sgehrd_(int *, int *, int *, float
*, int *, float *, float *, int *, int *), xerbla_(char
*, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
float bignum;
extern int slascl_(char *, int *, int *, float *,
float *, int *, int *, float *, int *, int *), slacpy_(char *, int *, int *, float *, int *,
float *, int *);
int wantsb, wantse, lastsl;
extern int sorghr_(int *, int *, int *, float
*, int *, float *, float *, int *, int *), shseqr_(char
*, char *, int *, int *, int *, float *, int *,
float *, float *, float *, int *, float *, int *, int *);
int minwrk, maxwrk;
int wantsn;
float smlnum;
int hswork;
extern int strsen_(char *, char *, int *, int *,
float *, int *, float *, int *, float *, float *, int *,
float *, float *, float *, int *, int *, int *, int *
);
int wantst, lquery, wantsv, wantvs;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEESX computes for an N-by-N float nonsymmetric matrix A, the */
/* eigenvalues, the float Schur form T, and, optionally, the matrix of */
/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* float Schur form so that selected eigenvalues are at the top left; */
/* computes a reciprocal condition number for the average of the */
/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
/* number for the right invariant subspace corresponding to the */
/* selected eigenvalues (RCONDV). The leading columns of Z form an */
/* orthonormal basis for this invariant subspace. */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
/* these quantities are called s and sep respectively). */
/* A float matrix is in float Schur form if it is upper quasi-triangular */
/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
/* the form */
/* [ a b ] */
/* [ c a ] */
/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
/* complex conjugate pair of eigenvalues is selected, then both */
/* are. Note that a selected complex eigenvalue may no longer */
/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned); in this */
/* case INFO may be set to N+3 (see INFO below). */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for average of selected eigenvalues only; */
/* = 'V': Computed for selected right invariant subspace only; */
/* = 'B': Computed for both. */
/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A is overwritten by its float Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELECT is true. (Complex conjugate */
/* pairs for which SELECT is true for either */
/* eigenvalue count as 2.) */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the float and imaginary parts, respectively, */
/* of the computed eigenvalues, in the same order that they */
/* appear on the diagonal of the output Schur form T. Complex */
/* conjugate pairs of eigenvalues appear consecutively with the */
/* eigenvalue having the positive imaginary part first. */
/* VS (output) REAL array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1, and if */
/* JOBVS = 'V', LDVS >= N. */
/* RCONDE (output) REAL */
/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
/* condition number for the average of the selected eigenvalues. */
/* Not referenced if SENSE = 'N' or 'V'. */
/* RCONDV (output) REAL */
/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
/* condition number for the selected right invariant subspace. */
/* Not referenced if SENSE = 'N' or 'E'. */
/* WORK (workspace/output) 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). */
/* Also, if SENSE = 'E' or 'V' or 'B', */
/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
/* selected eigenvalues computed by this routine. Note that */
/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
/* returned if LWORK < MAX(1,3*N), but if SENSE = 'E' or 'V' or */
/* 'B' this may not be large enough. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates upper bounds on the optimal sizes of the */
/* arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
/* may not be large enough. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates upper bounds on the optimal sizes of */
/* the arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* Not referenced if SORT = 'N'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the transformation which */
/* reduces A to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--iwork;
--bwork;
/* Function Body */
*info = 0;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
lquery = *lwork == -1 || *liwork == -1;
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < MAX(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "RWorkspace:" describe the */
/* minimal amount of float workspace needed at that point in the */
/* code, as well as the preferred amount for good performance. */
/* IWorkspace refers to int workspace. */
/* 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 SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
/* depends on SDIM, which is computed by the routine STRSEN later */
/* in the code.) */
if (*info == 0) {
liwrk = 1;
if (*n == 0) {
minwrk = 1;
lwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
n, &c__0);
minwrk = *n * 3;
shseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = work[1];
if (! wantvs) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = MAX(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = MAX(i__1,i__2);
}
lwrk = maxwrk;
if (! wantsn) {
/* Computing MAX */
i__1 = lwrk, i__2 = *n + *n * *n / 2;
lwrk = MAX(i__1,i__2);
}
if (wantsv || wantsb) {
liwrk = *n * *n / 4;
}
}
iwork[1] = liwrk;
work[1] = (float) lwrk;
if (*lwork < minwrk && ! lquery) {
*info = -16;
} else if (*liwork < 1 && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = 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);
}
/* Permute the matrix to make it more nearly triangular */
/* (RWorkspace: need N) */
ibal = 1;
sgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
slacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS */
/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
/* L10: */
}
/* Reorder eigenvalues, transform Schur vectors, and compute */
/* reciprocal condition numbers */
/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
/* otherwise, need N ) */
/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
/* otherwise, need 0 ) */
i__1 = *lwork - iwrk + 1;
strsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
i__1, &iwork[1], liwork, &icond);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
maxwrk = MAX(i__1,i__2);
}
if (icond == -15) {
/* Not enough float workspace */
*info = -16;
} else if (icond == -17) {
/* Not enough int workspace */
*info = -18;
} else if (icond > 0) {
/* STRSEN failed to reorder or to restore standard Schur form */
*info = icond + *n;
}
}
if (wantvs) {
/* Undo balancing */
/* (RWorkspace: need N) */
sgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
slascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
scopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr);
*rcondv = dum[0];
}
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], n, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.f) {
inxt = i__ + 1;
} else {
if (a[i__ + 1 + i__ * a_dim1] == 0.f) {
wi[i__] = 0.f;
wi[i__ + 1] = 0.f;
} else if (a[i__ + 1 + i__ * a_dim1] != 0.f && a[i__ + (
i__ + 1) * a_dim1] == 0.f) {
wi[i__] = 0.f;
wi[i__ + 1] = 0.f;
if (i__ > 1) {
i__2 = i__ - 1;
sswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
sswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
sswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
* vs_dim1 + 1], &c__1);
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.f;
}
inxt = i__ + 2;
}
L20:
;
}
}
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = MAX(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE;
lst2sl = TRUE;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.f) {
if (cursl) {
++(*sdim);
}
ip = 0;
if (cursl && ! lastsl) {
*info = *n + 2;
}
} else {
if (ip == 1) {
/* Last eigenvalue of conjugate pair */
cursl = cursl || lastsl;
lastsl = cursl;
if (cursl) {
*sdim += 2;
}
ip = -1;
if (cursl && ! lst2sl) {
*info = *n + 2;
}
} else {
/* First eigenvalue of conjugate pair */
ip = 1;
}
}
lst2sl = lastsl;
lastsl = cursl;
/* L30: */
}
}
work[1] = (float) maxwrk;
if (wantsv || wantsb) {
iwork[1] = *sdim * (*n - *sdim);
} else {
iwork[1] = 1;
}
return 0;
/* End of SGEESX */
} /* sgeesx_ */
/* ----------------------------------------------------------------------- */
/* 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 serrec_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error ex\002,\002its ***\002)";
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, ifst, ilst;
static real work[4], a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[
16] /* was [4][4] */;
static integer i__, j, m;
static real s[4], scale;
static integer iwork[4];
static real wi[4];
static integer nt;
static real wr[4];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), strexc_(char *, integer *, real *, integer
*, real *, integer *, integer *, integer *, real *, integer *), strsna_(char *, char *, logical *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, real *,
integer *, integer *, real *, integer *, integer *, integer *), strsen_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *, real *, integer *, integer *, integer *, integer *
), strsyl_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *);
static logical sel[4];
static real sep[4];
/* Fortran I/O blocks */
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
#define b_ref(a_1,a_2) b[(a_2)*4 + a_1 - 5]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SERREC tests the error exits for the routines for eigen- condition
estimation for REAL matrices:
STRSYL, STREXC, STRSNA and STRSEN.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
infoc_1.ok = TRUE_;
nt = 0;
/* Initialize A, B and SEL */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 0.f;
b_ref(i__, j) = 0.f;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, i__) = 1.f;
sel[i__ - 1] = TRUE_;
/* L30: */
}
/* Test STRSYL */
s_copy(srnamc_1.srnamt, "STRSYL", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
scale, &info);
chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STREXC */
s_copy(srnamc_1.srnamt, "STREXC", (ftnlen)6, (ftnlen)6);
ifst = 1;
ilst = 1;
infoc_1.infot = 1;
strexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ilst = 2;
strexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 0;
ilst = 1;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ifst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ifst = 1;
ilst = 0;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ilst = 2;
strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* Test STRSNA */
s_copy(srnamc_1.srnamt, "STRSNA", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__1, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
c__2, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
c__0, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
strsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__1, &m, work, &c__2, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
c__2, &m, work, &c__1, iwork, &info);
chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* Test STRSEN */
sel[0] = FALSE_;
s_copy(srnamc_1.srnamt, "STRSEN", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
work, &c__2, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__0, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__3, iwork, &c__2, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("E", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
work, &c__1, iwork, &c__0, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 17;
strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
work, &c__4, iwork, &c__1, &info);
chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
/* Print a summary line. */
if (infoc_1.ok) {
io___19.ciunit = infoc_1.nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___20.ciunit = infoc_1.nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of SERREC */
} /* serrec_ */
