/* 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_ */