/** * <p>Calculates roots of a polynomial.</p> * * @param a * Pointer to polynomial coefficients. * @param m * Number of polynomial coefficients stored in <CODE>a</CODE>. * @param rtr * Resulting real roots. * @param rti * Resulting imaginary roots. * @return <code>O_K</code> if successful, a (negative) error code otherwise */ INT16 dlm_roots(FLOAT64* A, COMPLEX64* Z, INT16 nA) { INT16 j, k; integer m = nA; integer ilo; integer ihi; integer info; integer c__1 = 1; integer lwork = 0; char job1[1] = { 'S' }; char job2[1] = { 'E' }; char compz[1] = { 'N' }; #ifdef __MAX_TYPE_32BIT int sgebal_(char*,integer*,real*,integer*,integer*,integer*,real*,integer*); int shseqr_(char*,char*,integer*,integer*,integer*,real*,integer*,real*,real*,real*,integer*,real*,integer*,integer*); #else int dgebal_(char*,integer*,doublereal*,integer*,integer*,integer*,doublereal*,integer*); int dhseqr_(char*,char*,integer*,integer*,integer*,doublereal*,integer*,doublereal*,doublereal*,doublereal*,integer*,doublereal*,integer*,integer*); #endif #define _H(i,j) *(hess+(j)+(i)*m) if ((!A) || (!Z)) return NOT_EXEC; k = 0; while ((k < m) && (*(A + k) == 0.0)) { k++; A++; } m -= k; m--; if (m <= 0) return NOT_EXEC; #ifdef __MAX_TYPE_32BIT real* hess = (real*) dlp_malloc((4*m+m*m)*sizeof(real)); if (!hess) return ERR_MEM; real* scale = hess + m * m; real* wr = scale + m; real* wi = wr + m; real* work = wi + m; #else doublereal* hess=(doublereal*)dlp_malloc((4*m+m*m)*sizeof(doublereal)); if(!hess) return ERR_MEM; doublereal* scale = hess + m*m; doublereal* wr = scale + m; doublereal* wi = wr + m; doublereal* work = wi + m; #endif lwork = m; for (k = 0; k < m; k++) { _H(m-1,k) = -A[k + 1] / A[0]; for (j = 0; j < m - 1; j++) _H(j,k) = ((j == (k - 1)) && (k > 0)) ? 1.0 : 0.0; } #ifdef __MAX_TYPE_32BIT sgebal_(job1, &m, hess, &m, &ilo, &ihi, scale, &info); shseqr_(job2, compz, &m, &ilo, &ihi, hess, &m, wr, wi, NULL, &c__1, work, &lwork, &info); #else dgebal_(job1, &m, hess, &m, &ilo, &ihi, scale, &info); dhseqr_(job2, compz, &m, &ilo, &ihi, hess, &m, wr, wi, NULL, &c__1, work, &lwork, &info); #endif dlp_free(hess); for (j = 0; j < m; j++) { Z[j].x = wr[j]; Z[j].y = wi[j]; } return (info == 0) ? O_K : NOT_EXEC; #undef _H }
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, real *a, integer *lda, real *wr, real *wi, real * vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer * ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, k; real r__, cs, sn; char job[1]; real scl, dum[1], eps; char side[1]; real anrm; integer ierr, itau, iwrk, nout; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); extern doublereal snrm2_(integer *, real *, integer *); integer icond; extern logical lsame_(char *, char *); extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int slabad_(real *, real *); logical scalea; real cscale; extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *, integer *, integer *, real *, integer *); extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); logical select[1]; real bignum; extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *); extern integer isamax_(integer *, real *, integer *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slartg_(real *, real *, real *, real *, real *), sorghr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), shseqr_( char *, char *, integer *, integer *, integer *, real *, integer * , real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, integer * , integer *, real *, integer *); integer minwrk, maxwrk; extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *, integer *); logical wantvl, wntsnb; integer hswork; logical wntsne; real smlnum; logical lquery, wantvr, wntsnn, wntsnv; /* -- LAPACK driver routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */ /* eigenvalues and, optionally, the left and/or right eigenvectors. */ /* Optionally also, it computes a balancing transformation to improve */ /* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ /* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */ /* (RCONDE), and reciprocal condition numbers for the right */ /* eigenvectors (RCONDV). */ /* The right eigenvector v(j) of A satisfies */ /* A * v(j) = lambda(j) * v(j) */ /* where lambda(j) is its eigenvalue. */ /* The left eigenvector u(j) of A satisfies */ /* u(j)**H * A = lambda(j) * u(j)**H */ /* where u(j)**H denotes the conjugate transpose of u(j). */ /* The computed eigenvectors are normalized to have Euclidean norm */ /* equal to 1 and largest component real. */ /* Balancing a matrix means permuting the rows and columns to make it */ /* more nearly upper triangular, and applying a diagonal similarity */ /* transformation D * A * D**(-1), where D is a diagonal matrix, to */ /* make its rows and columns closer in norm and the condition numbers */ /* of its eigenvalues and eigenvectors smaller. The computed */ /* reciprocal condition numbers correspond to the balanced matrix. */ /* Permuting rows and columns will not change the condition numbers */ /* (in exact arithmetic) but diagonal scaling will. For further */ /* explanation of balancing, see section 4.10.2 of the LAPACK */ /* Users' Guide. */ /* Arguments */ /* ========= */ /* BALANC (input) CHARACTER*1 */ /* Indicates how the input matrix should be diagonally scaled */ /* and/or permuted to improve the conditioning of its */ /* eigenvalues. */ /* = 'N': Do not diagonally scale or permute; */ /* = 'P': Perform permutations to make the matrix more nearly */ /* upper triangular. Do not diagonally scale; */ /* = 'S': Diagonally scale the matrix, i.e. replace A by */ /* D*A*D**(-1), where D is a diagonal matrix chosen */ /* to make the rows and columns of A more equal in */ /* norm. Do not permute; */ /* = 'B': Both diagonally scale and permute A. */ /* Computed reciprocal condition numbers will be for the matrix */ /* after balancing and/or permuting. Permuting does not change */ /* condition numbers (in exact arithmetic), but balancing does. */ /* JOBVL (input) CHARACTER*1 */ /* = 'N': left eigenvectors of A are not computed; */ /* = 'V': left eigenvectors of A are computed. */ /* If SENSE = 'E' or 'B', JOBVL must = 'V'. */ /* JOBVR (input) CHARACTER*1 */ /* = 'N': right eigenvectors of A are not computed; */ /* = 'V': right eigenvectors of A are computed. */ /* If SENSE = 'E' or 'B', JOBVR must = 'V'. */ /* SENSE (input) CHARACTER*1 */ /* Determines which reciprocal condition numbers are computed. */ /* = 'N': None are computed; */ /* = 'E': Computed for eigenvalues only; */ /* = 'V': Computed for right eigenvectors only; */ /* = 'B': Computed for eigenvalues and right eigenvectors. */ /* If SENSE = 'E' or 'B', both left and right eigenvectors */ /* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) REAL array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* On exit, A has been overwritten. If JOBVL = 'V' or */ /* JOBVR = 'V', A contains the real Schur form of the balanced */ /* version of the input matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* WR (output) REAL array, dimension (N) */ /* WI (output) REAL array, dimension (N) */ /* WR and WI contain the real and imaginary parts, */ /* respectively, of the computed eigenvalues. Complex */ /* conjugate pairs of eigenvalues will appear consecutively */ /* with the eigenvalue having the positive imaginary part */ /* first. */ /* VL (output) REAL array, dimension (LDVL,N) */ /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ /* after another in the columns of VL, in the same order */ /* as their eigenvalues. */ /* If JOBVL = 'N', VL is not referenced. */ /* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ /* the j-th column of VL. */ /* If the j-th and (j+1)-st eigenvalues form a complex */ /* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ /* u(j+1) = VL(:,j) - i*VL(:,j+1). */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1; if */ /* JOBVL = 'V', LDVL >= N. */ /* VR (output) REAL array, dimension (LDVR,N) */ /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ /* after another in the columns of VR, in the same order */ /* as their eigenvalues. */ /* If JOBVR = 'N', VR is not referenced. */ /* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ /* the j-th column of VR. */ /* If the j-th and (j+1)-st eigenvalues form a complex */ /* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ /* v(j+1) = VR(:,j) - i*VR(:,j+1). */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1, and if */ /* JOBVR = 'V', LDVR >= N. */ /* ILO (output) INTEGER */ /* IHI (output) INTEGER */ /* ILO and IHI are integer values determined when A was */ /* balanced. The balanced A(i,j) = 0 if I > J and */ /* J = 1,...,ILO-1 or I = IHI+1,...,N. */ /* SCALE (output) REAL array, dimension (N) */ /* Details of the permutations and scaling factors applied */ /* when balancing A. If P(j) is the index of the row and column */ /* interchanged with row and column j, and D(j) is the scaling */ /* factor applied to row and column j, then */ /* SCALE(J) = P(J), for J = 1,...,ILO-1 */ /* = D(J), for J = ILO,...,IHI */ /* = P(J) for J = IHI+1,...,N. */ /* The order in which the interchanges are made is N to IHI+1, */ /* then 1 to ILO-1. */ /* ABNRM (output) REAL */ /* The one-norm of the balanced matrix (the maximum */ /* of the sum of absolute values of elements of any column). */ /* RCONDE (output) REAL array, dimension (N) */ /* RCONDE(j) is the reciprocal condition number of the j-th */ /* eigenvalue. */ /* RCONDV (output) REAL array, dimension (N) */ /* RCONDV(j) is the reciprocal condition number of the j-th */ /* right eigenvector. */ /* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. If SENSE = 'N' or 'E', */ /* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */ /* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */ /* For good performance, LWORK must generally be larger. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* IWORK (workspace) INTEGER array, dimension (2*N-2) */ /* If SENSE = 'N' or 'E', not referenced. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the QR algorithm failed to compute all the */ /* eigenvalues, and no eigenvectors or condition numbers */ /* have been computed; elements 1:ILO-1 and i+1:N of WR */ /* and WI contain eigenvalues which have converged. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --wr; --wi; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --scale; --rconde; --rcondv; --work; --iwork; /* Function Body */ *info = 0; lquery = *lwork == -1; wantvl = lsame_(jobvl, "V"); wantvr = lsame_(jobvr, "V"); wntsnn = lsame_(sense, "N"); wntsne = lsame_(sense, "E"); wntsnv = lsame_(sense, "V"); wntsnb = lsame_(sense, "B"); if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") || lsame_(balanc, "B"))) { *info = -1; } else if (! wantvl && ! lsame_(jobvl, "N")) { *info = -2; } else if (! wantvr && ! lsame_(jobvr, "N")) { *info = -3; } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) && ! (wantvl && wantvr)) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || wantvl && *ldvl < *n) { *info = -11; } else if (*ldvr < 1 || wantvr && *ldvr < *n) { *info = -13; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* NB refers to the optimal block size for the immediately */ /* following subroutine, as returned by ILAENV. */ /* HSWORK refers to the workspace preferred by SHSEQR, as */ /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ /* the worst case.) */ if (*info == 0) { if (*n == 0) { minwrk = 1; maxwrk = 1; } else { maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, & c__0); if (wantvl) { shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); } else if (wantvr) { shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); } else { if (wntsnn) { shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); } else { shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); } } hswork = work[1]; if (! wantvl && ! wantvr) { minwrk = *n << 1; if (! wntsnn) { /* Computing MAX */ i__1 = minwrk, i__2 = *n * *n + *n * 6; minwrk = max(i__1,i__2); } maxwrk = max(maxwrk,hswork); if (! wntsnn) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *n + *n * 6; maxwrk = max(i__1,i__2); } } else { minwrk = *n * 3; if (! wntsnn && ! wntsne) { /* Computing MAX */ i__1 = minwrk, i__2 = *n * *n + *n * 6; minwrk = max(i__1,i__2); } maxwrk = max(maxwrk,hswork); /* Computing MAX */ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR", " ", n, &c__1, n, &c_n1); maxwrk = max(i__1,i__2); if (! wntsnn && ! wntsne) { /* Computing MAX */ i__1 = maxwrk, i__2 = *n * *n + *n * 6; maxwrk = max(i__1,i__2); } /* Computing MAX */ i__1 = maxwrk, i__2 = *n * 3; maxwrk = max(i__1,i__2); } maxwrk = max(maxwrk,minwrk); } work[1] = (real) maxwrk; if (*lwork < minwrk && ! lquery) { *info = -21; } } if (*info != 0) { i__1 = -(*info); xerbla_("SGEEVX", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ icond = 0; anrm = slange_("M", n, n, &a[a_offset], lda, dum); scalea = FALSE_; if (anrm > 0.f && anrm < smlnum) { scalea = TRUE_; cscale = smlnum; } else if (anrm > bignum) { scalea = TRUE_; cscale = bignum; } if (scalea) { slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr); } /* Balance the matrix and compute ABNRM */ sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr); *abnrm = slange_("1", n, n, &a[a_offset], lda, dum); if (scalea) { dum[0] = *abnrm; slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & ierr); *abnrm = dum[0]; } /* Reduce to upper Hessenberg form */ /* (Workspace: need 2*N, prefer N+N*NB) */ itau = 1; iwrk = itau + *n; i__1 = *lwork - iwrk + 1; sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & ierr); if (wantvl) { /* Want left eigenvectors */ /* Copy Householder vectors to VL */ *(unsigned char *)side = 'L'; slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ; /* Generate orthogonal matrix in VL */ /* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ i__1 = *lwork - iwrk + 1; sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VL */ /* (Workspace: need 1, prefer HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[ vl_offset], ldvl, &work[iwrk], &i__1, info); if (wantvr) { /* Want left and right eigenvectors */ /* Copy Schur vectors to VR */ *(unsigned char *)side = 'B'; slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); } } else if (wantvr) { /* Want right eigenvectors */ /* Copy Householder vectors to VR */ *(unsigned char *)side = 'R'; slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ; /* Generate orthogonal matrix in VR */ /* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ i__1 = *lwork - iwrk + 1; sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VR */ /* (Workspace: need 1, prefer HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } else { /* Compute eigenvalues only */ /* If condition numbers desired, compute Schur form */ if (wntsnn) { *(unsigned char *)job = 'E'; } else { *(unsigned char *)job = 'S'; } /* (Workspace: need 1, prefer HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ vr_offset], ldvr, &work[iwrk], &i__1, info); } /* If INFO > 0 from SHSEQR, then quit */ if (*info > 0) { goto L50; } if (wantvl || wantvr) { /* Compute left and/or right eigenvectors */ /* (Workspace: need 3*N) */ strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); } /* Compute condition numbers if desired */ /* (Workspace: need N*N+6*N unless SENSE = 'E') */ if (! wntsnn) { strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, &work[iwrk], n, &iwork[1], &icond); } if (wantvl) { /* Undo balancing of left eigenvectors */ sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, &ierr); /* Normalize left eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (wi[i__] == 0.f) { scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); } else if (wi[i__] > 0.f) { r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); scl = 1.f / slapy2_(&r__1, &r__2); sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { /* Computing 2nd power */ r__1 = vl[k + i__ * vl_dim1]; /* Computing 2nd power */ r__2 = vl[k + (i__ + 1) * vl_dim1]; work[k] = r__1 * r__1 + r__2 * r__2; /* L10: */ } k = isamax_(n, &work[1], &c__1); slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], &cs, &sn, &r__); srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * vl_dim1 + 1], &c__1, &cs, &sn); vl[k + (i__ + 1) * vl_dim1] = 0.f; } /* L20: */ } } if (wantvr) { /* Undo balancing of right eigenvectors */ sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, &ierr); /* Normalize right eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (wi[i__] == 0.f) { scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); } else if (wi[i__] > 0.f) { r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); scl = 1.f / slapy2_(&r__1, &r__2); sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { /* Computing 2nd power */ r__1 = vr[k + i__ * vr_dim1]; /* Computing 2nd power */ r__2 = vr[k + (i__ + 1) * vr_dim1]; work[k] = r__1 * r__1 + r__2 * r__2; /* L30: */ } k = isamax_(n, &work[1], &c__1); slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], &cs, &sn, &r__); srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * vr_dim1 + 1], &c__1, &cs, &sn); vr[k + (i__ + 1) * vr_dim1] = 0.f; } /* L40: */ } } /* Undo scaling if necessary */ L50: if (scalea) { i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + 1], &i__2, &ierr); i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + 1], &i__2, &ierr); if (*info == 0) { if ((wntsnv || wntsnb) && icond == 0) { slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ 1], n, &ierr); } } else { i__1 = *ilo - 1; slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], n, &ierr); i__1 = *ilo - 1; slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], n, &ierr); } } work[1] = (real) maxwrk; return 0; /* End of SGEEVX */ } /* sgeevx_ */
/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo, integer *knt, integer *nin) { /* System generated locals */ integer i__1, i__2; real r__1, r__2; /* Local variables */ integer i__, j, m, n; real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */, re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1], eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */; integer ifnd, icmp, iscl, info, lcmp[3], kmin; real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20]; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); real sepin[20], vimin, tolin, vrmin; integer iwork[40]; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); real witmp[20], wrtmp[20]; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *); logical select[20]; real bignum; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), shseqr_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real * , real *, integer *, real *, integer *, integer *) , strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *); real septmp[20]; extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *, integer *); real smlnum; /* Fortran I/O blocks */ static cilist io___5 = { 0, 0, 0, 0, 0 }; static cilist io___8 = { 0, 0, 0, 0, 0 }; static cilist io___11 = { 0, 0, 0, 0, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SGET37 tests STRSNA, a routine for estimating condition numbers of */ /* eigenvalues and/or right eigenvectors of a matrix. */ /* The test matrices are read from a file with logical unit number NIN. */ /* Arguments */ /* ========== */ /* RMAX (output) REAL array, dimension (3) */ /* Value of the largest test ratio. */ /* RMAX(1) = largest ratio comparing different calls to STRSNA */ /* RMAX(2) = largest error in reciprocal condition */ /* numbers taking their conditioning into account */ /* RMAX(3) = largest error in reciprocal condition */ /* numbers not taking their conditioning into */ /* account (may be larger than RMAX(2)) */ /* LMAX (output) INTEGER array, dimension (3) */ /* LMAX(i) is example number where largest test ratio */ /* RMAX(i) is achieved. Also: */ /* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */ /* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */ /* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */ /* NINFO (output) INTEGER array, dimension (3) */ /* NINFO(1) = No. of times SGEHRD returned INFO nonzero */ /* NINFO(2) = No. of times SHSEQR returned INFO nonzero */ /* NINFO(3) = No. of times STRSNA returned INFO nonzero */ /* KNT (output) INTEGER */ /* Total number of examples tested. */ /* NIN (input) INTEGER */ /* Input logical unit number */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --ninfo; --lmax; --rmax; /* Function Body */ eps = slamch_("P"); smlnum = slamch_("S") / eps; bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); /* EPSIN = 2**(-24) = precision to which input data computed */ eps = dmax(eps,5.9605e-8f); rmax[1] = 0.f; rmax[2] = 0.f; rmax[3] = 0.f; lmax[1] = 0; lmax[2] = 0; lmax[3] = 0; *knt = 0; ninfo[1] = 0; ninfo[2] = 0; ninfo[3] = 0; val[0] = sqrt(smlnum); val[1] = 1.f; val[2] = sqrt(bignum); /* Read input data until N=0. Assume input eigenvalues are sorted */ /* lexicographically (increasing by real part, then decreasing by */ /* imaginary part) */ L10: io___5.ciunit = *nin; s_rsle(&io___5); do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer)); e_rsle(); if (n == 0) { return 0; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___8.ciunit = *nin; s_rsle(&io___8); i__2 = n; for (j = 1; j <= i__2; ++j) { do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen) sizeof(real)); } e_rsle(); /* L20: */ } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { io___11.ciunit = *nin; s_rsle(&io___11); do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real)); do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real)); do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real)); do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real)); e_rsle(); /* L30: */ } tnrm = slange_("M", &n, &n, tmp, &c__20, work); /* Begin test */ for (iscl = 1; iscl <= 3; ++iscl) { /* Scale input matrix */ ++(*knt); slacpy_("F", &n, &n, tmp, &c__20, t, &c__20); vmul = val[iscl - 1]; i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1); /* L40: */ } if (tnrm == 0.f) { vmul = 1.f; } /* Compute eigenvalues and eigenvectors */ i__1 = 1200 - n; sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info); if (info != 0) { lmax[1] = *knt; ++ninfo[1]; goto L240; } i__1 = n - 2; for (j = 1; j <= i__1; ++j) { i__2 = n; for (i__ = j + 2; i__ <= i__2; ++i__) { t[i__ + j * 20 - 21] = 0.f; /* L50: */ } /* L60: */ } /* Compute Schur form */ shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work, &c__1200, &info); if (info != 0) { lmax[2] = *knt; ++ninfo[2]; goto L240; } /* Compute eigenvectors */ strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20, &n, &m, work, &info); /* Compute condition numbers */ strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20, s, sep, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } /* Sort eigenvalues and condition numbers lexicographically */ /* to compare with inputs */ scopy_(&n, wr, &c__1, wrtmp, &c__1); scopy_(&n, wi, &c__1, witmp, &c__1); scopy_(&n, s, &c__1, stmp, &c__1); scopy_(&n, sep, &c__1, septmp, &c__1); r__1 = 1.f / vmul; sscal_(&n, &r__1, septmp, &c__1); i__1 = n - 1; for (i__ = 1; i__ <= i__1; ++i__) { kmin = i__; vrmin = wrtmp[i__ - 1]; vimin = witmp[i__ - 1]; i__2 = n; for (j = i__ + 1; j <= i__2; ++j) { if (wrtmp[j - 1] < vrmin) { kmin = j; vrmin = wrtmp[j - 1]; vimin = witmp[j - 1]; } /* L70: */ } wrtmp[kmin - 1] = wrtmp[i__ - 1]; witmp[kmin - 1] = witmp[i__ - 1]; wrtmp[i__ - 1] = vrmin; witmp[i__ - 1] = vimin; vrmin = stmp[kmin - 1]; stmp[kmin - 1] = stmp[i__ - 1]; stmp[i__ - 1] = vrmin; vrmin = septmp[kmin - 1]; septmp[kmin - 1] = septmp[i__ - 1]; septmp[i__ - 1] = vrmin; /* L80: */ } /* Compare condition numbers for eigenvalues */ /* taking their condition numbers into account */ /* Computing MAX */ r__1 = (real) n * 2.f * eps * tnrm; v = dmax(r__1,smlnum); if (tnrm == 0.f) { v = 1.f; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > septmp[i__ - 1]) { tol = 1.f; } else { tol = v / septmp[i__ - 1]; } if (v > sepin[i__ - 1]) { tolin = 1.f; } else { tolin = v / sepin[i__ - 1]; } /* Computing MAX */ r__1 = tol, r__2 = smlnum / eps; tol = dmax(r__1,r__2); /* Computing MAX */ r__1 = tolin, r__2 = smlnum / eps; tolin = dmax(r__1,r__2); if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) { vmax = 1.f / eps; } else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) { vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol); } else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) { vmax = 1.f / eps; } else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) { vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin); } else { vmax = 1.f; } if (vmax > rmax[2]) { rmax[2] = vmax; if (ninfo[2] == 0) { lmax[2] = *knt; } } /* L90: */ } /* Compare condition numbers for eigenvectors */ /* taking their condition numbers into account */ i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > septmp[i__ - 1] * stmp[i__ - 1]) { tol = septmp[i__ - 1]; } else { tol = v / stmp[i__ - 1]; } if (v > sepin[i__ - 1] * sin__[i__ - 1]) { tolin = sepin[i__ - 1]; } else { tolin = v / sin__[i__ - 1]; } /* Computing MAX */ r__1 = tol, r__2 = smlnum / eps; tol = dmax(r__1,r__2); /* Computing MAX */ r__1 = tolin, r__2 = smlnum / eps; tolin = dmax(r__1,r__2); if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) { vmax = 1.f / eps; } else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) { vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol); } else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol)) { vmax = 1.f / eps; } else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) { vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin); } else { vmax = 1.f; } if (vmax > rmax[2]) { rmax[2] = vmax; if (ninfo[2] == 0) { lmax[2] = *knt; } } /* L100: */ } /* Compare condition numbers for eigenvalues */ /* without taking their condition numbers into account */ i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= ( real) (n << 1) * eps) { vmax = 1.f; } else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) { vmax = 1.f / eps; } else if (sin__[i__ - 1] > stmp[i__ - 1]) { vmax = sin__[i__ - 1] / stmp[i__ - 1]; } else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) { vmax = 1.f / eps; } else if (sin__[i__ - 1] < stmp[i__ - 1]) { vmax = stmp[i__ - 1] / sin__[i__ - 1]; } else { vmax = 1.f; } if (vmax > rmax[3]) { rmax[3] = vmax; if (ninfo[3] == 0) { lmax[3] = *knt; } } /* L110: */ } /* Compare condition numbers for eigenvectors */ /* without taking their condition numbers into account */ i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) { vmax = 1.f; } else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) { vmax = 1.f / eps; } else if (sepin[i__ - 1] > septmp[i__ - 1]) { vmax = sepin[i__ - 1] / septmp[i__ - 1]; } else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) { vmax = 1.f / eps; } else if (sepin[i__ - 1] < septmp[i__ - 1]) { vmax = septmp[i__ - 1] / sepin[i__ - 1]; } else { vmax = 1.f; } if (vmax > rmax[3]) { rmax[3] = vmax; if (ninfo[3] == 0) { lmax[3] = *knt; } } /* L120: */ } /* Compute eigenvalue condition numbers only and compare */ vmax = 0.f; dum[0] = -1.f; scopy_(&n, dum, &c__0, stmp, &c__1); scopy_(&n, dum, &c__0, septmp, &c__1); strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (stmp[i__ - 1] != s[i__ - 1]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } /* L130: */ } /* Compute eigenvector condition numbers only and compare */ scopy_(&n, dum, &c__0, stmp, &c__1); scopy_(&n, dum, &c__0, septmp, &c__1); strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (stmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != sep[i__ - 1]) { vmax = 1.f / eps; } /* L140: */ } /* Compute all condition numbers using SELECT and compare */ i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { select[i__ - 1] = TRUE_; /* L150: */ } scopy_(&n, dum, &c__0, stmp, &c__1); scopy_(&n, dum, &c__0, septmp, &c__1); strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (septmp[i__ - 1] != sep[i__ - 1]) { vmax = 1.f / eps; } if (stmp[i__ - 1] != s[i__ - 1]) { vmax = 1.f / eps; } /* L160: */ } /* Compute eigenvalue condition numbers using SELECT and compare */ scopy_(&n, dum, &c__0, stmp, &c__1); scopy_(&n, dum, &c__0, septmp, &c__1); strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (stmp[i__ - 1] != s[i__ - 1]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } /* L170: */ } /* Compute eigenvector condition numbers using SELECT and compare */ scopy_(&n, dum, &c__0, stmp, &c__1); scopy_(&n, dum, &c__0, septmp, &c__1); strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = n; for (i__ = 1; i__ <= i__1; ++i__) { if (stmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != sep[i__ - 1]) { vmax = 1.f / eps; } /* L180: */ } if (vmax > rmax[1]) { rmax[1] = vmax; if (ninfo[1] == 0) { lmax[1] = *knt; } } /* Select first real and first complex eigenvalue */ if (wi[0] == 0.f) { lcmp[0] = 1; ifnd = 0; i__1 = n; for (i__ = 2; i__ <= i__1; ++i__) { if (ifnd == 1 || wi[i__ - 1] == 0.f) { select[i__ - 1] = FALSE_; } else { ifnd = 1; lcmp[1] = i__; lcmp[2] = i__ + 1; scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1); scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], & c__1); scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1); scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], & c__1); } /* L190: */ } if (ifnd == 0) { icmp = 1; } else { icmp = 3; } } else { lcmp[0] = 1; lcmp[1] = 2; ifnd = 0; i__1 = n; for (i__ = 3; i__ <= i__1; ++i__) { if (ifnd == 1 || wi[i__ - 1] != 0.f) { select[i__ - 1] = FALSE_; } else { lcmp[2] = i__; ifnd = 1; scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1); scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1); } /* L200: */ } if (ifnd == 0) { icmp = 2; } else { icmp = 3; } } /* Compute all selected condition numbers */ scopy_(&icmp, dum, &c__0, stmp, &c__1); scopy_(&icmp, dum, &c__0, septmp, &c__1); strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = icmp; for (i__ = 1; i__ <= i__1; ++i__) { j = lcmp[i__ - 1]; if (septmp[i__ - 1] != sep[j - 1]) { vmax = 1.f / eps; } if (stmp[i__ - 1] != s[j - 1]) { vmax = 1.f / eps; } /* L210: */ } /* Compute selected eigenvalue condition numbers */ scopy_(&icmp, dum, &c__0, stmp, &c__1); scopy_(&icmp, dum, &c__0, septmp, &c__1); strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = icmp; for (i__ = 1; i__ <= i__1; ++i__) { j = lcmp[i__ - 1]; if (stmp[i__ - 1] != s[j - 1]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } /* L220: */ } /* Compute selected eigenvector condition numbers */ scopy_(&icmp, dum, &c__0, stmp, &c__1); scopy_(&icmp, dum, &c__0, septmp, &c__1); strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, & c__20, stmp, septmp, &n, &m, work, &n, iwork, &info); if (info != 0) { lmax[3] = *knt; ++ninfo[3]; goto L240; } i__1 = icmp; for (i__ = 1; i__ <= i__1; ++i__) { j = lcmp[i__ - 1]; if (stmp[i__ - 1] != dum[0]) { vmax = 1.f / eps; } if (septmp[i__ - 1] != sep[j - 1]) { vmax = 1.f / eps; } /* L230: */ } if (vmax > rmax[1]) { rmax[1] = vmax; if (ninfo[1] == 0) { lmax[1] = *knt; } } L240: ; } goto L10; /* End of SGET37 */ } /* sget37_ */
int main(void) { /* Local scalars */ char job, job_i; char compz, compz_i; lapack_int n, n_i; lapack_int ilo, ilo_i; lapack_int ihi, ihi_i; lapack_int ldh, ldh_i; lapack_int ldh_r; lapack_int ldz, ldz_i; lapack_int ldz_r; lapack_int lwork, lwork_i; lapack_int info, info_i; lapack_int i; int failed; /* Local arrays */ float *h = NULL, *h_i = NULL; float *wr = NULL, *wr_i = NULL; float *wi = NULL, *wi_i = NULL; float *z = NULL, *z_i = NULL; float *work = NULL, *work_i = NULL; float *h_save = NULL; float *wr_save = NULL; float *wi_save = NULL; float *z_save = NULL; float *h_r = NULL; float *z_r = NULL; /* Iniitialize the scalar parameters */ init_scalars_shseqr( &job, &compz, &n, &ilo, &ihi, &ldh, &ldz, &lwork ); ldh_r = n+2; ldz_r = n+2; job_i = job; compz_i = compz; n_i = n; ilo_i = ilo; ihi_i = ihi; ldh_i = ldh; ldz_i = ldz; lwork_i = lwork; /* Allocate memory for the LAPACK routine arrays */ h = (float *)LAPACKE_malloc( ldh*n * sizeof(float) ); wr = (float *)LAPACKE_malloc( n * sizeof(float) ); wi = (float *)LAPACKE_malloc( n * sizeof(float) ); z = (float *)LAPACKE_malloc( ldz*n * sizeof(float) ); work = (float *)LAPACKE_malloc( lwork * sizeof(float) ); /* Allocate memory for the C interface function arrays */ h_i = (float *)LAPACKE_malloc( ldh*n * sizeof(float) ); wr_i = (float *)LAPACKE_malloc( n * sizeof(float) ); wi_i = (float *)LAPACKE_malloc( n * sizeof(float) ); z_i = (float *)LAPACKE_malloc( ldz*n * sizeof(float) ); work_i = (float *)LAPACKE_malloc( lwork * sizeof(float) ); /* Allocate memory for the backup arrays */ h_save = (float *)LAPACKE_malloc( ldh*n * sizeof(float) ); wr_save = (float *)LAPACKE_malloc( n * sizeof(float) ); wi_save = (float *)LAPACKE_malloc( n * sizeof(float) ); z_save = (float *)LAPACKE_malloc( ldz*n * sizeof(float) ); /* Allocate memory for the row-major arrays */ h_r = (float *)LAPACKE_malloc( n*(n+2) * sizeof(float) ); z_r = (float *)LAPACKE_malloc( n*(n+2) * sizeof(float) ); /* Initialize input arrays */ init_h( ldh*n, h ); init_wr( n, wr ); init_wi( n, wi ); init_z( ldz*n, z ); init_work( lwork, work ); /* Backup the ouptut arrays */ for( i = 0; i < ldh*n; i++ ) { h_save[i] = h[i]; } for( i = 0; i < n; i++ ) { wr_save[i] = wr[i]; } for( i = 0; i < n; i++ ) { wi_save[i] = wi[i]; } for( i = 0; i < ldz*n; i++ ) { z_save[i] = z[i]; } /* Call the LAPACK routine */ shseqr_( &job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info ); /* Initialize input data, call the column-major middle-level * interface to LAPACK routine and check the results */ for( i = 0; i < ldh*n; i++ ) { h_i[i] = h_save[i]; } for( i = 0; i < n; i++ ) { wr_i[i] = wr_save[i]; } for( i = 0; i < n; i++ ) { wi_i[i] = wi_save[i]; } for( i = 0; i < ldz*n; i++ ) { z_i[i] = z_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_shseqr_work( LAPACK_COL_MAJOR, job_i, compz_i, n_i, ilo_i, ihi_i, h_i, ldh_i, wr_i, wi_i, z_i, ldz_i, work_i, lwork_i ); failed = compare_shseqr( h, h_i, wr, wr_i, wi, wi_i, z, z_i, info, info_i, compz, ldh, ldz, n ); if( failed == 0 ) { printf( "PASSED: column-major middle-level interface to shseqr\n" ); } else { printf( "FAILED: column-major middle-level interface to shseqr\n" ); } /* Initialize input data, call the column-major high-level * interface to LAPACK routine and check the results */ for( i = 0; i < ldh*n; i++ ) { h_i[i] = h_save[i]; } for( i = 0; i < n; i++ ) { wr_i[i] = wr_save[i]; } for( i = 0; i < n; i++ ) { wi_i[i] = wi_save[i]; } for( i = 0; i < ldz*n; i++ ) { z_i[i] = z_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } info_i = LAPACKE_shseqr( LAPACK_COL_MAJOR, job_i, compz_i, n_i, ilo_i, ihi_i, h_i, ldh_i, wr_i, wi_i, z_i, ldz_i ); failed = compare_shseqr( h, h_i, wr, wr_i, wi, wi_i, z, z_i, info, info_i, compz, ldh, ldz, n ); if( failed == 0 ) { printf( "PASSED: column-major high-level interface to shseqr\n" ); } else { printf( "FAILED: column-major high-level interface to shseqr\n" ); } /* Initialize input data, call the row-major middle-level * interface to LAPACK routine and check the results */ for( i = 0; i < ldh*n; i++ ) { h_i[i] = h_save[i]; } for( i = 0; i < n; i++ ) { wr_i[i] = wr_save[i]; } for( i = 0; i < n; i++ ) { wi_i[i] = wi_save[i]; } for( i = 0; i < ldz*n; i++ ) { z_i[i] = z_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, h_i, ldh, h_r, n+2 ); if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, z_i, ldz, z_r, n+2 ); } info_i = LAPACKE_shseqr_work( LAPACK_ROW_MAJOR, job_i, compz_i, n_i, ilo_i, ihi_i, h_r, ldh_r, wr_i, wi_i, z_r, ldz_r, work_i, lwork_i ); LAPACKE_sge_trans( LAPACK_ROW_MAJOR, n, n, h_r, n+2, h_i, ldh ); if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { LAPACKE_sge_trans( LAPACK_ROW_MAJOR, n, n, z_r, n+2, z_i, ldz ); } failed = compare_shseqr( h, h_i, wr, wr_i, wi, wi_i, z, z_i, info, info_i, compz, ldh, ldz, n ); if( failed == 0 ) { printf( "PASSED: row-major middle-level interface to shseqr\n" ); } else { printf( "FAILED: row-major middle-level interface to shseqr\n" ); } /* Initialize input data, call the row-major high-level * interface to LAPACK routine and check the results */ for( i = 0; i < ldh*n; i++ ) { h_i[i] = h_save[i]; } for( i = 0; i < n; i++ ) { wr_i[i] = wr_save[i]; } for( i = 0; i < n; i++ ) { wi_i[i] = wi_save[i]; } for( i = 0; i < ldz*n; i++ ) { z_i[i] = z_save[i]; } for( i = 0; i < lwork; i++ ) { work_i[i] = work[i]; } /* Init row_major arrays */ LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, h_i, ldh, h_r, n+2 ); if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, z_i, ldz, z_r, n+2 ); } info_i = LAPACKE_shseqr( LAPACK_ROW_MAJOR, job_i, compz_i, n_i, ilo_i, ihi_i, h_r, ldh_r, wr_i, wi_i, z_r, ldz_r ); LAPACKE_sge_trans( LAPACK_ROW_MAJOR, n, n, h_r, n+2, h_i, ldh ); if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { LAPACKE_sge_trans( LAPACK_ROW_MAJOR, n, n, z_r, n+2, z_i, ldz ); } failed = compare_shseqr( h, h_i, wr, wr_i, wi, wi_i, z, z_i, info, info_i, compz, ldh, ldz, n ); if( failed == 0 ) { printf( "PASSED: row-major high-level interface to shseqr\n" ); } else { printf( "FAILED: row-major high-level interface to shseqr\n" ); } /* Release memory */ if( h != NULL ) { LAPACKE_free( h ); } if( h_i != NULL ) { LAPACKE_free( h_i ); } if( h_r != NULL ) { LAPACKE_free( h_r ); } if( h_save != NULL ) { LAPACKE_free( h_save ); } if( wr != NULL ) { LAPACKE_free( wr ); } if( wr_i != NULL ) { LAPACKE_free( wr_i ); } if( wr_save != NULL ) { LAPACKE_free( wr_save ); } if( wi != NULL ) { LAPACKE_free( wi ); } if( wi_i != NULL ) { LAPACKE_free( wi_i ); } if( wi_save != NULL ) { LAPACKE_free( wi_save ); } if( z != NULL ) { LAPACKE_free( z ); } if( z_i != NULL ) { LAPACKE_free( z_i ); } if( z_r != NULL ) { LAPACKE_free( z_r ); } if( z_save != NULL ) { LAPACKE_free( z_save ); } if( work != NULL ) { LAPACKE_free( work ); } if( work_i != NULL ) { LAPACKE_free( work_i ); } return 0; }
/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a, integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, integer *lwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, k; real r__, cs, sn; integer ihi; real scl; integer ilo; real dum[1], eps; integer ibal; char side[1]; real anrm; integer ierr, itau, iwrk, nout; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); extern doublereal snrm2_(integer *, real *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int slabad_(real *, real *); logical scalea; real cscale; extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *, integer *, integer *, real *, integer *); extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); logical select[1]; real bignum; extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *); extern integer isamax_(integer *, real *, integer *); extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slartg_(real *, real *, real *, real *, real *), sorghr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *), shseqr_( char *, char *, integer *, integer *, integer *, real *, integer * , real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, integer * , integer *, real *, integer *); integer minwrk, maxwrk; logical wantvl; real smlnum; integer hswork; logical lquery, wantvr; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SGEEV computes for an N-by-N real nonsymmetric matrix A, the */ /* eigenvalues and, optionally, the left and/or right eigenvectors. */ /* The right eigenvector v(j) of A satisfies */ /* A * v(j) = lambda(j) * v(j) */ /* where lambda(j) is its eigenvalue. */ /* The left eigenvector u(j) of A satisfies */ /* u(j)**H * A = lambda(j) * u(j)**H */ /* where u(j)**H denotes the conjugate transpose of u(j). */ /* The computed eigenvectors are normalized to have Euclidean norm */ /* equal to 1 and largest component real. */ /* Arguments */ /* ========= */ /* JOBVL (input) CHARACTER*1 */ /* = 'N': left eigenvectors of A are not computed; */ /* = 'V': left eigenvectors of A are computed. */ /* JOBVR (input) CHARACTER*1 */ /* = 'N': right eigenvectors of A are not computed; */ /* = 'V': right eigenvectors of A are computed. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) REAL array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* On exit, A has been overwritten. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* WR (output) REAL array, dimension (N) */ /* WI (output) REAL array, dimension (N) */ /* WR and WI contain the real and imaginary parts, */ /* respectively, of the computed eigenvalues. Complex */ /* conjugate pairs of eigenvalues appear consecutively */ /* with the eigenvalue having the positive imaginary part */ /* first. */ /* VL (output) REAL array, dimension (LDVL,N) */ /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ /* after another in the columns of VL, in the same order */ /* as their eigenvalues. */ /* If JOBVL = 'N', VL is not referenced. */ /* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ /* the j-th column of VL. */ /* If the j-th and (j+1)-st eigenvalues form a complex */ /* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ /* u(j+1) = VL(:,j) - i*VL(:,j+1). */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1; if */ /* JOBVL = 'V', LDVL >= N. */ /* VR (output) REAL array, dimension (LDVR,N) */ /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ /* after another in the columns of VR, in the same order */ /* as their eigenvalues. */ /* If JOBVR = 'N', VR is not referenced. */ /* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ /* the j-th column of VR. */ /* If the j-th and (j+1)-st eigenvalues form a complex */ /* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ /* v(j+1) = VR(:,j) - i*VR(:,j+1). */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1; if */ /* JOBVR = 'V', LDVR >= N. */ /* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= max(1,3*N), and */ /* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */ /* performance, LWORK must generally be larger. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the QR algorithm failed to compute all the */ /* eigenvalues, and no eigenvectors have been computed; */ /* elements i+1:N of WR and WI contain eigenvalues which */ /* have converged. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --wr; --wi; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --work; /* Function Body */ *info = 0; lquery = *lwork == -1; wantvl = lsame_(jobvl, "V"); wantvr = lsame_(jobvr, "V"); if (! wantvl && ! lsame_(jobvl, "N")) { *info = -1; } else if (! wantvr && ! lsame_(jobvr, "N")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldvl < 1 || wantvl && *ldvl < *n) { *info = -9; } else if (*ldvr < 1 || wantvr && *ldvr < *n) { *info = -11; } /* Compute workspace */ /* (Note: Comments in the code beginning "Workspace:" describe the */ /* minimal amount of workspace needed at that point in the code, */ /* as well as the preferred amount for good performance. */ /* NB refers to the optimal block size for the immediately */ /* following subroutine, as returned by ILAENV. */ /* HSWORK refers to the workspace preferred by SHSEQR, as */ /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ /* the worst case.) */ if (*info == 0) { if (*n == 0) { minwrk = 1; maxwrk = 1; } else { maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &c__0); if (wantvl) { minwrk = *n << 2; /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "SORGHR", " ", n, &c__1, n, &c_n1); maxwrk = max(i__1,i__2); shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); hswork = work[1]; /* Computing MAX */ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * n + hswork; maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n << 2; maxwrk = max(i__1,i__2); } else if (wantvr) { minwrk = *n << 2; /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "SORGHR", " ", n, &c__1, n, &c_n1); maxwrk = max(i__1,i__2); shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); hswork = work[1]; /* Computing MAX */ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * n + hswork; maxwrk = max(i__1,i__2); /* Computing MAX */ i__1 = maxwrk, i__2 = *n << 2; maxwrk = max(i__1,i__2); } else { minwrk = *n * 3; shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); hswork = work[1]; /* Computing MAX */ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = * n + hswork; maxwrk = max(i__1,i__2); } maxwrk = max(maxwrk,minwrk); } work[1] = (real) maxwrk; if (*lwork < minwrk && ! lquery) { *info = -13; } } if (*info != 0) { i__1 = -(*info); xerbla_("SGEEV ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = slange_("M", n, n, &a[a_offset], lda, dum); scalea = FALSE_; if (anrm > 0.f && anrm < smlnum) { scalea = TRUE_; cscale = smlnum; } else if (anrm > bignum) { scalea = TRUE_; cscale = bignum; } if (scalea) { slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & ierr); } /* Balance the matrix */ /* (Workspace: need N) */ ibal = 1; sgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); /* Reduce to upper Hessenberg form */ /* (Workspace: need 3*N, prefer 2*N+N*NB) */ itau = ibal + *n; iwrk = itau + *n; i__1 = *lwork - iwrk + 1; sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &ierr); if (wantvl) { /* Want left eigenvectors */ /* Copy Householder vectors to VL */ *(unsigned char *)side = 'L'; slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) ; /* Generate orthogonal matrix in VL */ /* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ i__1 = *lwork - iwrk + 1; sorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VL */ /* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & vl[vl_offset], ldvl, &work[iwrk], &i__1, info); if (wantvr) { /* Want left and right eigenvectors */ /* Copy Schur vectors to VR */ *(unsigned char *)side = 'B'; slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); } } else if (wantvr) { /* Want right eigenvectors */ /* Copy Householder vectors to VR */ *(unsigned char *)side = 'R'; slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) ; /* Generate orthogonal matrix in VR */ /* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ i__1 = *lwork - iwrk + 1; sorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &i__1, &ierr); /* Perform QR iteration, accumulating Schur vectors in VR */ /* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & vr[vr_offset], ldvr, &work[iwrk], &i__1, info); } else { /* Compute eigenvalues only */ /* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ iwrk = itau; i__1 = *lwork - iwrk + 1; shseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & vr[vr_offset], ldvr, &work[iwrk], &i__1, info); } /* If INFO > 0 from SHSEQR, then quit */ if (*info > 0) { goto L50; } if (wantvl || wantvr) { /* Compute left and/or right eigenvectors */ /* (Workspace: need 4*N) */ strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); } if (wantvl) { /* Undo balancing of left eigenvectors */ /* (Workspace: need N) */ sgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl, &ierr); /* Normalize left eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (wi[i__] == 0.f) { scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); } else if (wi[i__] > 0.f) { r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); scl = 1.f / slapy2_(&r__1, &r__2); sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { /* Computing 2nd power */ r__1 = vl[k + i__ * vl_dim1]; /* Computing 2nd power */ r__2 = vl[k + (i__ + 1) * vl_dim1]; work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2; /* L10: */ } k = isamax_(n, &work[iwrk], &c__1); slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], &cs, &sn, &r__); srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * vl_dim1 + 1], &c__1, &cs, &sn); vl[k + (i__ + 1) * vl_dim1] = 0.f; } /* L20: */ } } if (wantvr) { /* Undo balancing of right eigenvectors */ /* (Workspace: need N) */ sgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr, &ierr); /* Normalize right eigenvectors and make largest component real */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (wi[i__] == 0.f) { scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); } else if (wi[i__] > 0.f) { r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); scl = 1.f / slapy2_(&r__1, &r__2); sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); i__2 = *n; for (k = 1; k <= i__2; ++k) { /* Computing 2nd power */ r__1 = vr[k + i__ * vr_dim1]; /* Computing 2nd power */ r__2 = vr[k + (i__ + 1) * vr_dim1]; work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2; /* L30: */ } k = isamax_(n, &work[iwrk], &c__1); slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], &cs, &sn, &r__); srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * vr_dim1 + 1], &c__1, &cs, &sn); vr[k + (i__ + 1) * vr_dim1] = 0.f; } /* L40: */ } } /* Undo scaling if necessary */ L50: if (scalea) { i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + 1], &i__2, &ierr); i__1 = *n - *info; /* Computing MAX */ i__3 = *n - *info; i__2 = max(i__3,1); slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + 1], &i__2, &ierr); if (*info > 0) { i__1 = ilo - 1; slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], n, &ierr); i__1 = ilo - 1; slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], n, &ierr); } } work[1] = (real) maxwrk; return 0; /* End of SGEEV */ } /* sgeev_ */
/* Subroutine */ int serrhs_(char *path, integer *nunit) { /* Format strings */ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e" "rror exits\002,\002 (\002,i3,\002 tests done)\002)"; static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes" "ts of the error \002,\002exits ***\002)"; /* Local variables */ real a[9] /* was [3][3] */, c__[9] /* was [3][3] */; integer i__, j, m; real s[3], w[28]; char c2[2]; real wi[3]; integer nt; real vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3]; integer ihi, ilo; logical sel[3]; real tau[3]; integer info; extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *, integer *, integer *, real *, integer *); integer ifaill[3], ifailr[3]; extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *), shsein_(char *, char *, char *, logical *, integer *, real *, integer *, real *, real *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *, integer *, integer *), sorghr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *), shseqr_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer * , real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , real *, integer *, integer *); /* Fortran I/O blocks */ static cilist io___1 = { 0, 0, 0, 0, 0 }; static cilist io___22 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___23 = { 0, 0, 0, fmt_9998, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SERRHS tests the error exits for SGEBAK, SGEBAL, SGEHRD, SORGHR, */ /* SORMHR, SHSEQR, SHSEIN, and STREVC. */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The LAPACK path name for the routines to be tested. */ /* NUNIT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Executable Statements .. */ infoc_1.nout = *nunit; io___1.ciunit = infoc_1.nout; s_wsle(&io___1); e_wsle(); s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); /* Set the variables to innocuous values. */ for (j = 1; j <= 3; ++j) { for (i__ = 1; i__ <= 3; ++i__) { a[i__ + j * 3 - 4] = 1.f / (real) (i__ + j); /* L10: */ } wi[j - 1] = (real) j; sel[j - 1] = TRUE_; /* L20: */ } infoc_1.ok = TRUE_; nt = 0; /* Test error exits of the nonsymmetric eigenvalue routines. */ if (lsamen_(&c__2, c2, "HS")) { /* SGEBAL */ s_copy(srnamc_1.srnamt, "SGEBAL", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; sgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info); chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info); chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; sgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info); chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 3; /* SGEBAK */ s_copy(srnamc_1.srnamt, "SGEBAK", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; sgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; sgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; sgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; sgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 9; sgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info); chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 9; /* SGEHRD */ s_copy(srnamc_1.srnamt, "SGEHRD", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; sgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; sgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info); chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; /* SORGHR */ s_copy(srnamc_1.srnamt, "SORGHR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; sorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; sorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info); chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; /* SORMHR */ s_copy(srnamc_1.srnamt, "SORMHR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; sormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; sormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; sormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; sormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, & c__1, w, &c__2, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; sormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, & c__2, w, &c__2, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; sormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; sormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; sormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__2, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; sormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; sormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, & c__1, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; sormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, & c__2, w, &c__1, &info); chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 16; /* SHSEQR */ s_copy(srnamc_1.srnamt, "SHSEQR", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; shseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; shseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; shseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; shseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; shseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; shseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; shseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; shseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; shseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1, w, &c__1, &info); chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 9; /* SHSEIN */ s_copy(srnamc_1.srnamt, "SHSEIN", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; shsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &c__0, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; shsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &c__0, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 3; shsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &c__0, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 5; shsein_("R", "N", "N", sel, &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, & c__1, &c__0, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; shsein_("R", "N", "N", sel, &c__2, a, &c__1, wr, wi, vl, &c__1, vr, & c__2, &c__4, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; shsein_("L", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, & c__1, &c__4, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 13; shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, & c__1, &c__4, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 14; shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, & c__2, &c__1, &m, w, ifaill, ifailr, &info); chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 8; /* STREVC */ s_copy(srnamc_1.srnamt, "STREVC", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; strevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; strevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; strevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 6; strevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 10; strevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 11; strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, & m, w, &info); chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); nt += 7; } /* Print a summary line. */ if (infoc_1.ok) { io___22.ciunit = infoc_1.nout; s_wsfe(&io___22); do_fio(&c__1, path, (ftnlen)3); do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer)); e_wsfe(); } else { io___23.ciunit = infoc_1.nout; s_wsfe(&io___23); do_fio(&c__1, path, (ftnlen)3); e_wsfe(); } return 0; /* End of SERRHS */ } /* serrhs_ */
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_ */