/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, integer *lwork, integer *info) { /* System generated locals */ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; /* Local variables */ integer i__, k; real aa, bb, cc, dd; integer ld; real cs; integer nh, it, ks, kt; real sn; integer ku, kv, ls, ns; real ss; integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; real swap; integer ktop; real zdum[1] /* was [1][1] */; integer kacc22, itmax, nsmax, nwmax, kwtop; extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slaqr3_(logical *, logical *, integer *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, integer *, real *, integer *), slaqr4_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, real *, integer *, integer *), slaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, integer *, real * , integer *, integer *, real *, integer *); integer nibble; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); char jbcmpz[2]; extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *); integer nwupbd; logical sorted; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLAQR0 computes the eigenvalues of a Hessenberg matrix H */ /* and, optionally, the matrices T and Z from the Schur decomposition */ /* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ /* Schur form), and Z is the orthogonal matrix of Schur vectors. */ /* Optionally Z may be postmultiplied into an input orthogonal */ /* matrix Q so that this routine can give the Schur factorization */ /* of a matrix A which has been reduced to the Hessenberg form H */ /* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ /* Arguments */ /* ========= */ /* WANTT (input) LOGICAL */ /* = .TRUE. : the full Schur form T is required; */ /* = .FALSE.: only eigenvalues are required. */ /* WANTZ (input) LOGICAL */ /* = .TRUE. : the matrix of Schur vectors Z is required; */ /* = .FALSE.: Schur vectors are not required. */ /* N (input) INTEGER */ /* The order of the matrix H. N .GE. 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that H is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */ /* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ /* previous call to SGEBAL, and then passed to SGEHRD when the */ /* matrix output by SGEBAL is reduced to Hessenberg form. */ /* Otherwise, ILO and IHI should be set to 1 and N, */ /* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ /* If N = 0, then ILO = 1 and IHI = 0. */ /* H (input/output) REAL array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ /* the upper quasi-triangular matrix T from the Schur */ /* decomposition (the Schur form); 2-by-2 diagonal blocks */ /* (corresponding to complex conjugate pairs of eigenvalues) */ /* are returned in standard form, with H(i,i) = H(i+1,i+1) */ /* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */ /* .FALSE., then the contents of H are unspecified on exit. */ /* (The output value of H when INFO.GT.0 is given under the */ /* description of INFO below.) */ /* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ /* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH .GE. max(1,N). */ /* WR (output) REAL array, dimension (IHI) */ /* WI (output) REAL array, dimension (IHI) */ /* The real and imaginary parts, respectively, of the computed */ /* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ /* and WI(ILO:IHI). If two eigenvalues are computed as a */ /* complex conjugate pair, they are stored in consecutive */ /* elements of WR and WI, say the i-th and (i+1)th, with */ /* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ /* the eigenvalues are stored in the same order as on the */ /* diagonal of the Schur form returned in H, with */ /* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ /* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ /* WI(i+1) = -WI(i). */ /* ILOZ (input) INTEGER */ /* IHIZ (input) INTEGER */ /* Specify the rows of Z to which transformations must be */ /* applied if WANTZ is .TRUE.. */ /* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ /* Z (input/output) REAL array, dimension (LDZ,IHI) */ /* If WANTZ is .FALSE., then Z is not referenced. */ /* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ /* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ /* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ /* (The output value of Z when INFO.GT.0 is given under */ /* the description of INFO below.) */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. if WANTZ is .TRUE. */ /* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ /* WORK (workspace/output) REAL array, dimension LWORK */ /* On exit, if LWORK = -1, WORK(1) returns an estimate of */ /* the optimal value for LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK .GE. max(1,N) */ /* is sufficient, but LWORK typically as large as 6*N may */ /* be required for optimal performance. A workspace query */ /* to determine the optimal workspace size is recommended. */ /* If LWORK = -1, then SLAQR0 does a workspace query. */ /* In this case, SLAQR0 checks the input parameters and */ /* estimates the optimal workspace size for the given */ /* values of N, ILO and IHI. The estimate is returned */ /* in WORK(1). No error message related to LWORK is */ /* issued by XERBLA. Neither H nor Z are accessed. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* .GT. 0: if INFO = i, SLAQR0 failed to compute all of */ /* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ /* and WI contain those eigenvalues which have been */ /* successfully computed. (Failures are rare.) */ /* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ /* the remaining unconverged eigenvalues are the eigen- */ /* values of the upper Hessenberg matrix rows and */ /* columns ILO through INFO of the final, output */ /* value of H. */ /* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ /* (*) (initial value of H)*U = U*(final value of H) */ /* where U is an orthogonal matrix. The final */ /* value of H is upper Hessenberg and quasi-triangular */ /* in rows and columns INFO+1 through IHI. */ /* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ /* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ /* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of WANTT.) */ /* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ /* accessed. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* References: */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ /* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ /* 929--947, 2002. */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ /* of Matrix Analysis, volume 23, pages 948--973, 2002. */ /* ================================================================ */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . SLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== Exceptional deflation windows: try to cure rare */ /* . slow convergence by varying the size of the */ /* . deflation window after KEXNW iterations. ==== */ /* ==== Exceptional shifts: try to cure rare slow convergence */ /* . with ad-hoc exceptional shifts every KEXSH iterations. */ /* . ==== */ /* ==== The constants WILK1 and WILK2 are used to form the */ /* . exceptional shifts. ==== */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* ==== Quick return for N = 0: nothing to do. ==== */ if (*n == 0) { work[1] = 1.f; return 0; } if (*n <= 11) { /* ==== Tiny matrices must use SLAHQR. ==== */ lwkopt = 1; if (*lwork != -1) { slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & wi[1], iloz, ihiz, &z__[z_offset], ldz, info); } } else { /* ==== Use small bulge multi-shift QR with aggressive early */ /* . deflation on larger-than-tiny matrices. ==== */ /* ==== Hope for the best. ==== */ *info = 0; /* ==== Set up job flags for ILAENV. ==== */ if (*wantt) { *(unsigned char *)jbcmpz = 'S'; } else { *(unsigned char *)jbcmpz = 'E'; } if (*wantz) { *(unsigned char *)&jbcmpz[1] = 'V'; } else { *(unsigned char *)&jbcmpz[1] = 'N'; } /* ==== NWR = recommended deflation window size. At this */ /* . point, N .GT. NTINY = 11, so there is enough */ /* . subdiagonal workspace for NWR.GE.2 as required. */ /* . (In fact, there is enough subdiagonal space for */ /* . NWR.GE.3.) ==== */ nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nwr = max(2,nwr); /* Computing MIN */ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2); nwr = min(i__1,nwr); /* ==== NSR = recommended number of simultaneous shifts. */ /* . At this point N .GT. NTINY = 11, so there is at */ /* . enough subdiagonal workspace for NSR to be even */ /* . and greater than or equal to two as required. ==== */ nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); /* Computing MIN */ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi - *ilo; nsr = min(i__1,i__2); /* Computing MAX */ i__1 = 2, i__2 = nsr - nsr % 2; nsr = max(i__1,i__2); /* ==== Estimate optimal workspace ==== */ /* ==== Workspace query call to SLAQR3 ==== */ i__1 = nwr + 1; slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], &c_n1); /* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */ /* Computing MAX */ i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; lwkopt = max(i__1,i__2); /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (real) lwkopt; return 0; } /* ==== SLAHQR/SLAQR0 crossover point ==== */ nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nmin = max(11,nmin); /* ==== Nibble crossover point ==== */ nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nibble = max(0,nibble); /* ==== Accumulate reflections during ttswp? Use block */ /* . 2-by-2 structure during matrix-matrix multiply? ==== */ kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); kacc22 = max(0,kacc22); kacc22 = min(2,kacc22); /* ==== NWMAX = the largest possible deflation window for */ /* . which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n - 1) / 3, i__2 = *lwork / 2; nwmax = min(i__1,i__2); nw = nwmax; /* ==== NSMAX = the Largest number of simultaneous shifts */ /* . for which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; nsmax = min(i__1,i__2); nsmax -= nsmax % 2; /* ==== NDFL: an iteration count restarted at deflation. ==== */ ndfl = 1; /* ==== ITMAX = iteration limit ==== */ /* Computing MAX */ i__1 = 10, i__2 = *ihi - *ilo + 1; itmax = max(i__1,i__2) * 30; /* ==== Last row and column in the active block ==== */ kbot = *ihi; /* ==== Main Loop ==== */ i__1 = itmax; for (it = 1; it <= i__1; ++it) { /* ==== Done when KBOT falls below ILO ==== */ if (kbot < *ilo) { goto L90; } /* ==== Locate active block ==== */ i__2 = *ilo + 1; for (k = kbot; k >= i__2; --k) { if (h__[k + (k - 1) * h_dim1] == 0.f) { goto L20; } /* L10: */ } k = *ilo; L20: ktop = k; /* ==== Select deflation window size: */ /* . Typical Case: */ /* . If possible and advisable, nibble the entire */ /* . active block. If not, use size MIN(NWR,NWMAX) */ /* . or MIN(NWR+1,NWMAX) depending upon which has */ /* . the smaller corresponding subdiagonal entry */ /* . (a heuristic). */ /* . */ /* . Exceptional Case: */ /* . If there have been no deflations in KEXNW or */ /* . more iterations, then vary the deflation window */ /* . size. At first, because, larger windows are, */ /* . in general, more powerful than smaller ones, */ /* . rapidly increase the window to the maximum possible. */ /* . Then, gradually reduce the window size. ==== */ nh = kbot - ktop + 1; nwupbd = min(nh,nwmax); if (ndfl < 5) { nw = min(nwupbd,nwr); } else { /* Computing MIN */ i__2 = nwupbd, i__3 = nw << 1; nw = min(i__2,i__3); } if (nw < nwmax) { if (nw >= nh - 1) { nw = nh; } else { kwtop = kbot - nw + 1; if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], dabs(r__1)) > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], dabs(r__2))) { ++nw; } } } if (ndfl < 5) { ndec = -1; } else if (ndec >= 0 || nw >= nwupbd) { ++ndec; if (nw - ndec < 2) { ndec = 0; } nw -= ndec; } /* ==== Aggressive early deflation: */ /* . split workspace under the subdiagonal into */ /* . - an nw-by-nw work array V in the lower */ /* . left-hand-corner, */ /* . - an NW-by-at-least-NW-but-more-is-better */ /* . (NW-by-NHO) horizontal work array along */ /* . the bottom edge, */ /* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ /* . vertical work array along the left-hand-edge. */ /* . ==== */ kv = *n - nw + 1; kt = nw + 1; nho = *n - nw - 1 - kt + 1; kwv = nw + 2; nve = *n - nw - kwv + 1; /* ==== Aggressive early deflation ==== */ slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); /* ==== Adjust KBOT accounting for new deflations. ==== */ kbot -= ld; /* ==== KS points to the shifts. ==== */ ks = kbot - ls + 1; /* ==== Skip an expensive QR sweep if there is a (partly */ /* . heuristic) reason to expect that many eigenvalues */ /* . will deflate without it. Here, the QR sweep is */ /* . skipped if many eigenvalues have just been deflated */ /* . or if the remaining active block is small. */ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min( nmin,nwmax)) { /* ==== NS = nominal number of simultaneous shifts. */ /* . This may be lowered (slightly) if SLAQR3 */ /* . did not provide that many shifts. ==== */ /* Computing MIN */ /* Computing MAX */ i__4 = 2, i__5 = kbot - ktop; i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5); ns = min(i__2,i__3); ns -= ns % 2; /* ==== If there have been no deflations */ /* . in a multiple of KEXSH iterations, */ /* . then try exceptional shifts. */ /* . Otherwise use shifts provided by */ /* . SLAQR3 above or from the eigenvalues */ /* . of a trailing principal submatrix. ==== */ if (ndfl % 6 == 0) { ks = kbot - ns + 1; /* Computing MAX */ i__3 = ks + 1, i__4 = ktop + 2; i__2 = max(i__3,i__4); for (i__ = kbot; i__ >= i__2; i__ += -2) { ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1) ) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2)); aa = ss * .75f + h__[i__ + i__ * h_dim1]; bb = ss; cc = ss * -.4375f; dd = aa; slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] , &wr[i__], &wi[i__], &cs, &sn); /* L30: */ } if (ks == ktop) { wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; wi[ks + 1] = 0.f; wr[ks] = wr[ks + 1]; wi[ks] = wi[ks + 1]; } } else { /* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */ /* . SLAHQR on a trailing principal submatrix to */ /* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ /* . there is enough space below the subdiagonal */ /* . to fit an NS-by-NS scratch array.) ==== */ if (kbot - ks + 1 <= ns / 2) { ks = kbot - ns + 1; kt = *n - ns + 1; slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & h__[kt + h_dim1], ldh); if (ns > nmin) { slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &work[1], lwork, &inf); } else { slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &inf); } ks += inf; /* ==== In case of a rare QR failure use */ /* . eigenvalues of the trailing 2-by-2 */ /* . principal submatrix. ==== */ if (ks >= kbot) { aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; cc = h__[kbot + (kbot - 1) * h_dim1]; bb = h__[kbot - 1 + kbot * h_dim1]; dd = h__[kbot + kbot * h_dim1]; slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) ; ks = kbot - 1; } } if (kbot - ks + 1 > ns) { /* ==== Sort the shifts (Helps a little) */ /* . Bubble sort keeps complex conjugate */ /* . pairs together. ==== */ sorted = FALSE_; i__2 = ks + 1; for (k = kbot; k >= i__2; --k) { if (sorted) { goto L60; } sorted = TRUE_; i__3 = k - 1; for (i__ = ks; i__ <= i__3; ++i__) { if ((r__1 = wr[i__], dabs(r__1)) + (r__2 = wi[ i__], dabs(r__2)) < (r__3 = wr[i__ + 1], dabs(r__3)) + (r__4 = wi[i__ + 1], dabs(r__4))) { sorted = FALSE_; swap = wr[i__]; wr[i__] = wr[i__ + 1]; wr[i__ + 1] = swap; swap = wi[i__]; wi[i__] = wi[i__ + 1]; wi[i__ + 1] = swap; } /* L40: */ } /* L50: */ } L60: ; } /* ==== Shuffle shifts into pairs of real shifts */ /* . and pairs of complex conjugate shifts */ /* . assuming complex conjugate shifts are */ /* . already adjacent to one another. (Yes, */ /* . they are.) ==== */ i__2 = ks + 2; for (i__ = kbot; i__ >= i__2; i__ += -2) { if (wi[i__] != -wi[i__ - 1]) { swap = wr[i__]; wr[i__] = wr[i__ - 1]; wr[i__ - 1] = wr[i__ - 2]; wr[i__ - 2] = swap; swap = wi[i__]; wi[i__] = wi[i__ - 1]; wi[i__ - 1] = wi[i__ - 2]; wi[i__ - 2] = swap; } /* L70: */ } } /* ==== If there are only two shifts and both are */ /* . real, then use only one. ==== */ if (kbot - ks + 1 == 2) { if (wi[kbot] == 0.f) { if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1], dabs(r__1)) < (r__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], dabs(r__2))) { wr[kbot - 1] = wr[kbot]; } else { wr[kbot] = wr[kbot - 1]; } } } /* ==== Use up to NS of the the smallest magnatiude */ /* . shifts. If there aren't NS shifts available, */ /* . then use them all, possibly dropping one to */ /* . make the number of shifts even. ==== */ /* Computing MIN */ i__2 = ns, i__3 = kbot - ks + 1; ns = min(i__2,i__3); ns -= ns % 2; ks = kbot - ns + 1; /* ==== Small-bulge multi-shift QR sweep: */ /* . split workspace under the subdiagonal into */ /* . - a KDU-by-KDU work array U in the lower */ /* . left-hand-corner, */ /* . - a KDU-by-at-least-KDU-but-more-is-better */ /* . (KDU-by-NHo) horizontal work array WH along */ /* . the bottom edge, */ /* . - and an at-least-KDU-but-more-is-better-by-KDU */ /* . (NVE-by-KDU) vertical work WV arrow along */ /* . the left-hand-edge. ==== */ kdu = ns * 3 - 3; ku = *n - kdu + 1; kwh = kdu + 1; nho = *n - kdu - 3 - (kdu + 1) + 1; kwv = kdu + 4; nve = *n - kdu - kwv + 1; /* ==== Small-bulge multi-shift QR sweep ==== */ slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], ldh); } /* ==== Note progress (or the lack of it). ==== */ if (ld > 0) { ndfl = 1; } else { ++ndfl; } /* ==== End of main loop ==== */ /* L80: */ } /* ==== Iteration limit exceeded. Set INFO to show where */ /* . the problem occurred and exit. ==== */ *info = kbot; L90: ; } /* ==== Return the optimal value of LWORK. ==== */ work[1] = (real) lwkopt; /* ==== End of SLAQR0 ==== */ return 0; } /* slaqr0_ */
/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * work, integer *lwork) { /* System generated locals */ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; real r__1, r__2, r__3, r__4, r__5, r__6; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; real s, aa, bb, cc, dd, cs, sn; integer jw; real evi, evk, foo; integer kln; real tau, ulp; integer lwk1, lwk2; real beta; integer kend, kcol, info, ifst, ilst, ltop, krow; logical bulge; extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), sgemm_( char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); integer infqr; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); integer kwtop; extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slabad_(real *, real *) ; extern real slamch_(char *); extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *); real safmin; extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, real *); real safmax; extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *); logical sorted; extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *); real smlnum; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ================================================================ */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Estimate optimal workspace. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --sr; --si; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; wv_dim1 = *ldwv; wv_offset = 1 + wv_dim1; wv -= wv_offset; --work; /* Function Body */ /* Computing MIN */ i__1 = *nw; i__2 = *kbot - *ktop + 1; // , expr subst jw = min(i__1,i__2); if (jw <= 2) { lwkopt = 1; } else { /* ==== Workspace query call to SGEHRD ==== */ i__1 = jw - 1; sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1]; /* ==== Workspace query call to SORMHR ==== */ i__1 = jw - 1; sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info); lwk2 = (integer) work[1]; /* ==== Optimal workspace ==== */ lwkopt = jw + max(lwk1,lwk2); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (real) lwkopt; return 0; } /* ==== Nothing to do ... */ /* ... for an empty active block ... ==== */ *ns = 0; *nd = 0; work[1] = 1.f; if (*ktop > *kbot) { return 0; } /* ... nor for an empty deflation window. ==== */ if (*nw < 1) { return 0; } /* ==== Machine constants ==== */ safmin = slamch_("SAFE MINIMUM"); safmax = 1.f / safmin; slabad_(&safmin, &safmax); ulp = slamch_("PRECISION"); smlnum = safmin * ((real) (*n) / ulp); /* ==== Setup deflation window ==== */ /* Computing MIN */ i__1 = *nw; i__2 = *kbot - *ktop + 1; // , expr subst jw = min(i__1,i__2); kwtop = *kbot - jw + 1; if (kwtop == *ktop) { s = 0.f; } else { s = h__[kwtop + (kwtop - 1) * h_dim1]; } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ sr[kwtop] = h__[kwtop + kwtop * h_dim1]; si[kwtop] = 0.f; *ns = 1; *nd = 0; /* Computing MAX */ r__2 = smlnum; r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( r__1)); // , expr subst if (abs(s) <= max(r__2,r__3)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { h__[kwtop + (kwtop - 1) * h_dim1] = 0.f; } } work[1] = 1.f; return 0; } /* ==== Convert to spike-triangular form. (In case of a */ /* . rare QR failure, this routine continues to do */ /* . aggressive early deflation using that part of */ /* . the deflation window that converged using INFQR */ /* . here and there to keep track.) ==== */ slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt); i__1 = jw - 1; i__2 = *ldh + 1; i__3 = *ldt + 1; scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); /* ==== STREXC needs a clean margin near the diagonal ==== */ i__1 = jw - 3; for (j = 1; j <= i__1; ++j) { t[j + 2 + j * t_dim1] = 0.f; t[j + 3 + j * t_dim1] = 0.f; /* L10: */ } if (jw > 2) { t[jw + (jw - 2) * t_dim1] = 0.f; } /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; L20: if (ilst <= *ns) { if (*ns == 1) { bulge = FALSE_; } else { bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f; } /* ==== Small spike tip test for deflation ==== */ if (! bulge) { /* ==== Real eigenvalue ==== */ foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1)); if (foo == 0.f) { foo = abs(s); } /* Computing MAX */ r__2 = smlnum; r__3 = ulp * foo; // , expr subst if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= max(r__2,r__3)) { /* ==== Deflatable ==== */ --(*ns); } else { /* ==== Undeflatable. Move it up out of the way. */ /* . (STREXC can not fail in this case.) ==== */ ifst = *ns; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ++ilst; } } else { /* ==== Complex conjugate pair ==== */ foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* ns - 1 + *ns * t_dim1], abs(r__2))); if (foo == 0.f) { foo = abs(s); } /* Computing MAX */ r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)); r__4 = (r__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); // , expr subst /* Computing MAX */ r__5 = smlnum; r__6 = ulp * foo; // , expr subst if (max(r__3,r__4) <= max(r__5,r__6)) { /* ==== Deflatable ==== */ *ns += -2; } else { /* ==== Undeflatable. Move them up out of the way. */ /* . Fortunately, STREXC does the right thing with */ /* . ILST in case of a rare exchange failure. ==== */ ifst = *ns; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ilst += 2; } } /* ==== End deflation detection loop ==== */ goto L20; } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s = 0.f; } if (*ns < jw) { /* ==== sorting diagonal blocks of T improves accuracy for */ /* . graded matrices. Bubble sort deals well with */ /* . exchange failures. ==== */ sorted = FALSE_; i__ = *ns + 1; L30: if (sorted) { goto L50; } sorted = TRUE_; kend = i__ - 1; i__ = infqr + 1; if (i__ == *ns) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { k = i__ + 1; } else { k = i__ + 2; } L40: if (k <= kend) { if (k == i__ + 1) { evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1)); } else { evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = t[i__ + (i__ + 1) * t_dim1], abs(r__2))); } if (k == kend) { evk = (r__1 = t[k + k * t_dim1], abs(r__1)); } else if (t[k + 1 + k * t_dim1] == 0.f) { evk = (r__1 = t[k + k * t_dim1], abs(r__1)); } else { evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + (k + 1) * t_dim1], abs(r__2))); } if (evi >= evk) { i__ = k; } else { sorted = FALSE_; ifst = i__; ilst = k; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); if (info == 0) { i__ = ilst; } else { i__ = k; } } if (i__ == kend) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { k = i__ + 1; } else { k = i__ + 2; } goto L40; } goto L30; L50: ; } /* ==== Restore shift/eigenvalue array from T ==== */ i__ = jw; L60: if (i__ >= infqr + 1) { if (i__ == infqr + 1) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.f; --i__; } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.f; --i__; } else { aa = t[i__ - 1 + (i__ - 1) * t_dim1]; cc = t[i__ + (i__ - 1) * t_dim1]; bb = t[i__ - 1 + i__ * t_dim1]; dd = t[i__ + i__ * t_dim1]; slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn); i__ += -2; } goto L60; } if (*ns < jw || s == 0.f) { if (*ns > 1 && s != 0.f) { /* ==== Reflect spike back into lower triangle ==== */ scopy_(ns, &v[v_offset], ldv, &work[1], &c__1); beta = work[1]; slarfg_(ns, &beta, &work[2], &c__1, &tau); work[1] = 1.f; i__1 = jw - 2; i__2 = jw - 2; slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); } /* ==== Copy updated reduced window into place ==== */ if (kwtop > 1) { h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; } slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh); i__1 = jw - 1; i__2 = *ldt + 1; i__3 = *ldh + 1; scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3); /* ==== Accumulate orthogonal matrix in order update */ /* . H and Z, if requested. ==== */ if (*ns > 1 && s != 0.f) { i__1 = *lwork - jw; sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info); } /* ==== Update vertical slab in H ==== */ if (*wantt) { ltop = 1; } else { ltop = *ktop; } i__1 = kwtop - 1; i__2 = *nv; for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv; i__4 = kwtop - krow; // , expr subst kln = min(i__3,i__4); sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv); slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); /* L70: */ } /* ==== Update horizontal slab in H ==== */ if (*wantt) { i__2 = *n; i__1 = *nh; for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) { /* Computing MIN */ i__3 = *nh; i__4 = *n - kcol + 1; // , expr subst kln = min(i__3,i__4); sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt); slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); /* L80: */ } } /* ==== Update vertical slab in Z ==== */ if (*wantz) { i__1 = *ihiz; i__2 = *nv; for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv; i__4 = *ihiz - krow + 1; // , expr subst kln = min(i__3,i__4); sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ wv_offset], ldwv); slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); /* L90: */ } } } /* ==== Return the number of deflations ... ==== */ *nd = jw - *ns; /* ==== ... and the number of shifts. (Subtracting */ /* . INFQR from the spike length takes care */ /* . of the case of a rare QR failure while */ /* . calculating eigenvalues of the deflation */ /* . window.) ==== */ *ns -= infqr; /* ==== Return optimal workspace. ==== */ work[1] = (real) lwkopt; /* ==== End of SLAQR2 ==== */ return 0; }
/* ----------------------------------------------------------------------- */ /* Subroutine */ int sneupd_(logical *rvec, char *howmny, logical *select, real *dr, real *di, real *z__, integer *ldz, real *sigmar, real * sigmai, real *workev, char *bmat, integer *n, char *which, integer * nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv, integer *iparam, integer *ipntr, real *workd, real *workl, integer * lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen which_len) { /* System generated locals */ integer v_dim1, v_offset, z_dim1, z_offset, i__1; real r__1, r__2; doublereal d__1; /* Local variables */ static integer j, k, ih, jj, np; static real vl[1] /* was [1][1] */; static integer ibd, ldh, ldq, iri; static real sep; static integer irr, wri, wrr, mode; static real eps23; extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, integer *, real *, integer *, real *, integer *); static integer ierr; static real temp; static integer iwev; static char type__[6]; static real temp1; extern doublereal snrm2_(integer *, real *, integer *); static integer ihbds, iconj; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static real conds; static logical reord; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen); static integer nconv, iwork[1]; static real rnorm; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static integer ritzi; extern /* Subroutine */ int strmm_(char *, char *, char *, char *, integer *, integer *, real *, real *, integer *, real *, integer * , ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *, integer *, integer *, char *, ftnlen), smout_(integer *, integer * , integer *, real *, integer *, integer *, char *, ftnlen); static integer ritzr; extern /* Subroutine */ int svout_(integer *, integer *, real *, integer * , char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer * , real *, real *, integer *); static integer nconv2; extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, ftnlen, ftnlen); static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv, ishift, numcnv; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen), slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *, ftnlen), strevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real *, integer *, integer * , integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *, char *, logical *, integer *, real *, integer *, real *, integer * , real *, real *, integer *, real *, real *, real *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer *, real *, real *, real *, real *, real *, ftnlen); /* %----------------------------------------------------% */ /* | Include files for debugging and timing information | */ /* %----------------------------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %---------------------------------% */ /* | See debug.doc for documentation | */ /* %---------------------------------% */ /* %------------------% */ /* | Scalar Arguments | */ /* %------------------% */ /* %--------------------------------% */ /* | See stat.doc for documentation | */ /* %--------------------------------% */ /* \SCCS Information: @(#) */ /* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */ /* %-----------------% */ /* | Array Arguments | */ /* %-----------------% */ /* %------------% */ /* | Parameters | */ /* %------------% */ /* %---------------% */ /* | Local Scalars | */ /* %---------------% */ /* %----------------------% */ /* | External Subroutines | */ /* %----------------------% */ /* %--------------------% */ /* | External Functions | */ /* %--------------------% */ /* %---------------------% */ /* | Intrinsic Functions | */ /* %---------------------% */ /* %-----------------------% */ /* | Executable Statements | */ /* %-----------------------% */ /* %------------------------% */ /* | Set default parameters | */ /* %------------------------% */ /* Parameter adjustments */ z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --workd; --resid; --di; --dr; --workev; --select; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --iparam; --ipntr; --workl; /* Function Body */ msglvl = debug_1.mneupd; mode = iparam[7]; nconv = iparam[5]; *info = 0; /* %---------------------------------% */ /* | Get machine dependent constant. | */ /* %---------------------------------% */ eps23 = slamch_("Epsilon-Machine", (ftnlen)15); d__1 = (doublereal) eps23; eps23 = pow_dd(&d__1, &c_b3); /* %--------------% */ /* | Quick return | */ /* %--------------% */ ierr = 0; if (nconv <= 0) { ierr = -14; } else if (*n <= 0) { ierr = -1; } else if (*nev <= 0) { ierr = -2; } else if (*ncv <= *nev + 1 || *ncv > *n) { ierr = -3; } else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) { ierr = -5; } else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G') { ierr = -6; } else /* if(complicated condition) */ { /* Computing 2nd power */ i__1 = *ncv; if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) { ierr = -7; } else if (*(unsigned char *)howmny != 'A' && *(unsigned char *) howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) { ierr = -13; } else if (*(unsigned char *)howmny == 'S') { ierr = -12; } } if (mode == 1 || mode == 2) { s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6); } else if (mode == 3 && *sigmai == 0.f) { s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6); } else if (mode == 3) { s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6); } else if (mode == 4) { s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6); } else { ierr = -10; } if (mode == 1 && *(unsigned char *)bmat == 'G') { ierr = -11; } /* %------------% */ /* | Error Exit | */ /* %------------% */ if (ierr != 0) { *info = ierr; goto L9000; } /* %--------------------------------------------------------% */ /* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */ /* | etc... and the remaining workspace. | */ /* | Also update pointer to be used on output. | */ /* | Memory is laid out as follows: | */ /* | workl(1:ncv*ncv) := generated Hessenberg matrix | */ /* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */ /* | parts of ritz values | */ /* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */ /* %--------------------------------------------------------% */ /* %-----------------------------------------------------------% */ /* | The following is used and set by SNEUPD. | */ /* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */ /* | real part of the Ritz values. | */ /* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */ /* | imaginary part of the Ritz values. | */ /* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */ /* | error bounds of the Ritz values | */ /* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */ /* | quasi-triangular matrix for H | */ /* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */ /* | associated matrix representation of the invariant | */ /* | subspace for H. | */ /* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */ /* %-----------------------------------------------------------% */ ih = ipntr[5]; ritzr = ipntr[6]; ritzi = ipntr[7]; bounds = ipntr[8]; ldh = *ncv; ldq = *ncv; iheigr = bounds + ldh; iheigi = iheigr + ldh; ihbds = iheigi + ldh; iuptri = ihbds + ldh; invsub = iuptri + ldh * *ncv; ipntr[9] = iheigr; ipntr[10] = iheigi; ipntr[11] = ihbds; ipntr[12] = iuptri; ipntr[13] = invsub; wrr = 1; wri = *ncv + 1; iwev = wri + *ncv; /* %-----------------------------------------% */ /* | irr points to the REAL part of the Ritz | */ /* | values computed by _neigh before | */ /* | exiting _naup2. | */ /* | iri points to the IMAGINARY part of the | */ /* | Ritz values computed by _neigh | */ /* | before exiting _naup2. | */ /* | ibd points to the Ritz estimates | */ /* | computed by _neigh before exiting | */ /* | _naup2. | */ /* %-----------------------------------------% */ irr = ipntr[14] + *ncv * *ncv; iri = irr + *ncv; ibd = iri + *ncv; /* %------------------------------------% */ /* | RNORM is B-norm of the RESID(1:N). | */ /* %------------------------------------% */ rnorm = workl[ih + 2]; workl[ih + 2] = 0.f; if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: " "Real part of Ritz values passed in from _NAUPD.", (ftnlen)55); svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: " "Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55); svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: " "Ritz estimates passed in from _NAUPD.", (ftnlen)45); } if (*rvec) { reord = FALSE_; /* %---------------------------------------------------% */ /* | Use the temporary bounds array to store indices | */ /* | These will be used to mark the select array later | */ /* %---------------------------------------------------% */ i__1 = *ncv; for (j = 1; j <= i__1; ++j) { workl[bounds + j - 1] = (real) j; select[j] = FALSE_; /* L10: */ } /* %-------------------------------------% */ /* | Select the wanted Ritz values. | */ /* | Sort the Ritz values so that the | */ /* | wanted ones appear at the tailing | */ /* | NEV positions of workl(irr) and | */ /* | workl(iri). Move the corresponding | */ /* | error estimates in workl(bound) | */ /* | accordingly. | */ /* %-------------------------------------% */ np = *ncv - *nev; ishift = 0; sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[ bounds], &workl[1], &workl[np + 1], (ftnlen)2); if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu" "pd: Real part of Ritz values after calling _NGETS.", ( ftnlen)54); svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu" "pd: Imag part of Ritz values after calling _NGETS.", ( ftnlen)54); svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit, "_neupd: Ritz value indices after calling _NGETS.", ( ftnlen)48); } /* %-----------------------------------------------------% */ /* | Record indices of the converged wanted Ritz values | */ /* | Mark the select array for possible reordering | */ /* %-----------------------------------------------------% */ numcnv = 0; i__1 = *ncv; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri + *ncv - j]); temp1 = dmax(r__1,r__2); jj = workl[bounds + *ncv - j]; if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) { select[jj] = TRUE_; ++numcnv; if (jj > nconv) { reord = TRUE_; } } /* L11: */ } /* %-----------------------------------------------------------% */ /* | Check the count (numcnv) of converged Ritz values with | */ /* | the number (nconv) reported by dnaupd. If these two | */ /* | are different then there has probably been an error | */ /* | caused by incorrect passing of the dnaupd data. | */ /* %-----------------------------------------------------------% */ if (msglvl > 2) { ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd" ": Number of specified eigenvalues", (ftnlen)39); ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:" " Number of \"converged\" eigenvalues", (ftnlen)41); } if (numcnv != nconv) { *info = -15; goto L9000; } /* %-----------------------------------------------------------% */ /* | Call LAPACK routine slahqr to compute the real Schur form | */ /* | of the upper Hessenberg matrix returned by SNAUPD. | */ /* | Make a copy of the upper Hessenberg matrix. | */ /* | Initialize the Schur vector matrix Q to the identity. | */ /* %-----------------------------------------------------------% */ i__1 = ldh * *ncv; scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1); slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, ( ftnlen)3); slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, & workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], & ldq, &ierr); scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); if (ierr != 0) { *info = -8; goto L9000; } if (msglvl > 1) { svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit, "_neupd: Real part of the eigenvalues of H", (ftnlen)41); svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit, "_neupd: Imaginary part of the Eigenvalues of H", (ftnlen) 46); svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit, "_neupd: Last row of the Schur vector matrix", (ftnlen)43) ; if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, & debug_1.ndigit, "_neupd: The upper quasi-triangular " "matrix ", (ftnlen)42); } } if (reord) { /* %-----------------------------------------------------% */ /* | Reorder the computed upper quasi-triangular matrix. | */ /* %-----------------------------------------------------% */ strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, & workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], & nconv2, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, & ierr, (ftnlen)4, (ftnlen)1); if (nconv2 < nconv) { nconv = nconv2; } if (ierr == 1) { *info = 1; goto L9000; } if (msglvl > 2) { svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit, "_neupd: Real part of the eigenvalues of H--reordered" , (ftnlen)52); svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit, "_neupd: Imag part of the eigenvalues of H--reordered" , (ftnlen)52); if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, & debug_1.ndigit, "_neupd: Quasi-triangular matrix" " after re-ordering", (ftnlen)49); } } } /* %---------------------------------------% */ /* | Copy the last row of the Schur vector | */ /* | into workl(ihbds). This will be used | */ /* | to compute the Ritz estimates of | */ /* | converged Ritz values. | */ /* %---------------------------------------% */ scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1); /* %----------------------------------------------------% */ /* | Place the computed eigenvalues of H into DR and DI | */ /* | if a spectral transformation was not used. | */ /* %----------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } /* %----------------------------------------------------------% */ /* | Compute the QR factorization of the matrix representing | */ /* | the wanted invariant subspace located in the first NCONV | */ /* | columns of workl(invsub,ldq). | */ /* %----------------------------------------------------------% */ sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv + 1], &ierr); /* %---------------------------------------------------------% */ /* | * Postmultiply V by Q using sorm2r. | */ /* | * Copy the first NCONV columns of VQ into Z. | */ /* | * Postmultiply Z by R. | */ /* | The N by NCONV matrix Z is now a matrix representation | */ /* | of the approximate invariant subspace associated with | */ /* | the Ritz values in workl(iheigr) and workl(iheigi) | */ /* | The first NCONV columns of V are now approximate Schur | */ /* | vectors associated with the real upper quasi-triangular | */ /* | matrix of order NCONV in workl(iuptri) | */ /* %---------------------------------------------------------% */ sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq, &workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen) 5, (ftnlen)11); slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, ( ftnlen)3); i__1 = nconv; for (j = 1; j <= i__1; ++j) { /* %---------------------------------------------------% */ /* | Perform both a column and row scaling if the | */ /* | diagonal element of workl(invsub,ldq) is negative | */ /* | I'm lazy and don't take advantage of the upper | */ /* | quasi-triangular form of workl(iuptri,ldq) | */ /* | Note that since Q is orthogonal, R is a diagonal | */ /* | matrix consisting of plus or minus ones | */ /* %---------------------------------------------------% */ if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) { sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq); sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1); } /* L20: */ } if (*(unsigned char *)howmny == 'A') { /* %--------------------------------------------% */ /* | Compute the NCONV wanted eigenvectors of T | */ /* | located in workl(iuptri,ldq). | */ /* %--------------------------------------------% */ i__1 = *ncv; for (j = 1; j <= i__1; ++j) { if (j <= nconv) { select[j] = TRUE_; } else { select[j] = FALSE_; } /* L30: */ } strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq, vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1], &ierr, (ftnlen)5, (ftnlen)6); if (ierr != 0) { *info = -9; goto L9000; } /* %------------------------------------------------% */ /* | Scale the returning eigenvectors so that their | */ /* | Euclidean norms are all one. LAPACK subroutine | */ /* | strevc returns each eigenvector normalized so | */ /* | that the element of largest magnitude has | */ /* | magnitude 1; | */ /* %------------------------------------------------% */ iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] == 0.f) { /* %----------------------% */ /* | real eigenvalue case | */ /* %----------------------% */ temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1); } else { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* | columns, we further normalize by the | */ /* | square root of two. | */ /* %-------------------------------------------% */ if (iconj == 0) { r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], & c__1); r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1); temp = slapy2_(&r__1, &r__2); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], & c__1); r__1 = 1.f / temp; sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1); iconj = 1; } else { iconj = 0; } } /* L40: */ } sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[ ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1); iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] != 0.f) { /* %-------------------------------------------% */ /* | Complex conjugate pair case. Note that | */ /* | since the real and imaginary part of | */ /* | the eigenvector are stored in consecutive | */ /* %-------------------------------------------% */ if (iconj == 0) { workev[j] = slapy2_(&workev[j], &workev[j + 1]); workev[j + 1] = workev[j]; iconj = 1; } else { iconj = 0; } } /* L45: */ } if (msglvl > 2) { scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], & c__1); svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit, "_neupd: Last row of the eigenvector matrix for T", ( ftnlen)48); if (msglvl > 3) { smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, & debug_1.ndigit, "_neupd: The eigenvector matrix " "for T", (ftnlen)36); } } /* %---------------------------------------% */ /* | Copy Ritz estimates into workl(ihbds) | */ /* %---------------------------------------% */ scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1); /* %---------------------------------------------------------% */ /* | Compute the QR factorization of the eigenvector matrix | */ /* | associated with leading portion of T in the first NCONV | */ /* | columns of workl(invsub,ldq). | */ /* %---------------------------------------------------------% */ sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[* ncv + 1], &ierr); /* %----------------------------------------------% */ /* | * Postmultiply Z by Q. | */ /* | * Postmultiply Z by R. | */ /* | The N by NCONV matrix Z is now contains the | */ /* | Ritz vectors associated with the Ritz values | */ /* | in workl(iheigr) and workl(iheigi). | */ /* %----------------------------------------------% */ sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], & ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], & ierr, (ftnlen)5, (ftnlen)11); strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, & c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen) 5, (ftnlen)5, (ftnlen)12, (ftnlen)8); } } else { /* %------------------------------------------------------% */ /* | An approximate invariant subspace is not needed. | */ /* | Place the Ritz values computed SNAUPD into DR and DI | */ /* %------------------------------------------------------% */ scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1); scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1); scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1); scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1); } /* %------------------------------------------------% */ /* | Transform the Ritz values and possibly vectors | */ /* | and corresponding error bounds of OP to those | */ /* | of A*x = lambda*B*x. | */ /* %------------------------------------------------% */ if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) { if (*rvec) { sscal_(ncv, &rnorm, &workl[ihbds], &c__1); } } else { /* %---------------------------------------% */ /* | A spectral transformation was used. | */ /* | * Determine the Ritz estimates of the | */ /* | Ritz values in the original system. | */ /* %---------------------------------------% */ if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { if (*rvec) { sscal_(ncv, &rnorm, &workl[ihbds], &c__1); } i__1 = *ncv; for (k = 1; k <= i__1; ++k) { temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1]) ; workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs( r__1)) / temp / temp; /* L50: */ } } else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* L60: */ } } else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { /* L70: */ } } /* %-----------------------------------------------------------% */ /* | * Transform the Ritz values back to the original system. | */ /* | For TYPE = 'SHIFTI' the transformation is | */ /* | lambda = 1/theta + sigma | */ /* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */ /* | Rayleigh quotients or a projection. See remark 3 above.| */ /* | NOTES: | */ /* | *The Ritz vectors are not affected by the transformation. | */ /* %-----------------------------------------------------------% */ if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) { i__1 = *ncv; for (k = 1; k <= i__1; ++k) { temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1]) ; workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp + *sigmar; workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp + *sigmai; /* L80: */ } scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 || s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) { scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1); scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1); } } if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) { svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un" "transformed real part of the Ritz valuess.", (ftnlen)52); svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un" "transformed imag part of the Ritz valuess.", (ftnlen)52); svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne" "upd: Ritz estimates of untransformed Ritz values.", (ftnlen) 52); } else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) { svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re" "al parts of converged Ritz values.", (ftnlen)44); svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im" "ag parts of converged Ritz values.", (ftnlen)44); svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne" "upd: Associated Ritz estimates.", (ftnlen)34); } /* %-------------------------------------------------% */ /* | Eigenvector Purification step. Formally perform | */ /* | one of inverse subspace iteration. Only used | */ /* | for MODE = 2. | */ /* %-------------------------------------------------% */ if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", ( ftnlen)6, (ftnlen)6) == 0) { /* %------------------------------------------------% */ /* | Purify the computed Ritz vectors by adding a | */ /* | little bit of the residual vector: | */ /* | T | */ /* | resid(:)*( e s ) / theta | */ /* | NCV | */ /* | where H s = s theta. Remember that when theta | */ /* | has nonzero imaginary part, the corresponding | */ /* | Ritz vector is stored across two columns of Z. | */ /* %------------------------------------------------% */ iconj = 0; i__1 = nconv; for (j = 1; j <= i__1; ++j) { if (workl[iheigi + j - 1] == 0.f) { workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[ iheigr + j - 1]; } else if (iconj == 0) { temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1]) ; workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[ iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] * workl[iheigi + j - 1]) / temp / temp; workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[ iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[iheigi + j - 1]) / temp / temp; iconj = 1; } else { iconj = 0; } /* L110: */ } /* %---------------------------------------% */ /* | Perform a rank one update to Z and | */ /* | purify all the Ritz vectors together. | */ /* %---------------------------------------% */ sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[ z_offset], ldz); } L9000: return 0; /* %---------------% */ /* | End of SNEUPD | */ /* %---------------% */ } /* sneupd_ */
/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * work, integer *lwork) { /* System generated locals */ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; real r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ integer i__, j, k; real s, aa, bb, cc, dd, cs, sn; integer jw; real evi, evk, foo; integer kln; real tau, ulp; integer lwk1, lwk2; real beta; integer kend, kcol, info, ifst, ilst, ltop, krow; logical bulge; integer infqr; integer kwtop; real safmin; real safmax; logical sorted; real smlnum; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.2.1) -- */ /* -- April 2009 -- */ /* This subroutine is identical to SLAQR3 except that it avoids */ /* recursion by calling SLAHQR instead of SLAQR4. */ /* ****************************************************************** */ /* Aggressive early deflation: */ /* This subroutine accepts as input an upper Hessenberg matrix */ /* H and performs an orthogonal similarity transformation */ /* designed to detect and deflate fully converged eigenvalues from */ /* a trailing principal submatrix. On output H has been over- */ /* written by a new Hessenberg matrix that is a perturbation of */ /* an orthogonal similarity transformation of H. It is to be */ /* hoped that the final version of H has many zero subdiagonal */ /* entries. */ /* ****************************************************************** */ /* WANTT (input) LOGICAL */ /* If .TRUE., then the Hessenberg matrix H is fully updated */ /* so that the quasi-triangular Schur factor may be */ /* computed (in cooperation with the calling subroutine). */ /* If .FALSE., then only enough of H is updated to preserve */ /* the eigenvalues. */ /* WANTZ (input) LOGICAL */ /* If .TRUE., then the orthogonal matrix Z is updated so */ /* so that the orthogonal Schur factor may be computed */ /* (in cooperation with the calling subroutine). */ /* If .FALSE., then Z is not referenced. */ /* N (input) INTEGER */ /* The order of the matrix H and (if WANTZ is .TRUE.) the */ /* order of the orthogonal matrix Z. */ /* KTOP (input) INTEGER */ /* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ /* KBOT and KTOP together determine an isolated block */ /* along the diagonal of the Hessenberg matrix. */ /* KBOT (input) INTEGER */ /* It is assumed without a check that either */ /* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ /* determine an isolated block along the diagonal of the */ /* Hessenberg matrix. */ /* NW (input) INTEGER */ /* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ /* H (input/output) REAL array, dimension (LDH,N) */ /* On input the initial N-by-N section of H stores the */ /* Hessenberg matrix undergoing aggressive early deflation. */ /* On output H has been transformed by an orthogonal */ /* similarity transformation, perturbed, and the returned */ /* to Hessenberg form that (it is to be hoped) has some */ /* zero subdiagonal entries. */ /* LDH (input) integer */ /* Leading dimension of H just as declared in the calling */ /* subroutine. N .LE. LDH */ /* ILOZ (input) INTEGER */ /* IHIZ (input) INTEGER */ /* Specify the rows of Z to which transformations must be */ /* Z (input/output) REAL array, dimension (LDZ,N) */ /* IF WANTZ is .TRUE., then on output, the orthogonal */ /* similarity transformation mentioned above has been */ /* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ /* If WANTZ is .FALSE., then Z is unreferenced. */ /* LDZ (input) integer */ /* The leading dimension of Z just as declared in the */ /* calling subroutine. 1 .LE. LDZ. */ /* NS (output) integer */ /* The number of unconverged (ie approximate) eigenvalues */ /* returned in SR and SI that may be used as shifts by the */ /* calling subroutine. */ /* ND (output) integer */ /* The number of converged eigenvalues uncovered by this */ /* subroutine. */ /* SR (output) REAL array, dimension KBOT */ /* SI (output) REAL array, dimension KBOT */ /* On output, the real and imaginary parts of approximate */ /* eigenvalues that may be used for shifts are stored in */ /* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ /* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ /* The real and imaginary parts of converged eigenvalues */ /* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ /* SI(KBOT-ND+1) through SI(KBOT), respectively. */ /* V (workspace) REAL array, dimension (LDV,NW) */ /* An NW-by-NW work array. */ /* LDV (input) integer scalar */ /* The leading dimension of V just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* NH (input) integer scalar */ /* The number of columns of T. NH.GE.NW. */ /* T (workspace) REAL array, dimension (LDT,NW) */ /* LDT (input) integer */ /* The leading dimension of T just as declared in the */ /* calling subroutine. NW .LE. LDT */ /* NV (input) integer */ /* The number of rows of work array WV available for */ /* workspace. NV.GE.NW. */ /* WV (workspace) REAL array, dimension (LDWV,NW) */ /* LDWV (input) integer */ /* The leading dimension of W just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* WORK (workspace) REAL array, dimension LWORK. */ /* On exit, WORK(1) is set to an estimate of the optimal value */ /* of LWORK for the given values of N, NW, KTOP and KBOT. */ /* LWORK (input) integer */ /* The dimension of the work array WORK. LWORK = 2*NW */ /* suffices, but greater efficiency may result from larger */ /* values of LWORK. */ /* If LWORK = -1, then a workspace query is assumed; SLAQR2 */ /* only estimates the optimal workspace size for the given */ /* values of N, NW, KTOP and KBOT. The estimate is returned */ /* in WORK(1). No error message related to LWORK is issued */ /* by XERBLA. Neither H nor Z are accessed. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* ==== Estimate optimal workspace. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --sr; --si; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; wv_dim1 = *ldwv; wv_offset = 1 + wv_dim1; wv -= wv_offset; --work; /* Function Body */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); if (jw <= 2) { lwkopt = 1; } else { /* ==== Workspace query call to SGEHRD ==== */ i__1 = jw - 1; sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1]; /* ==== Workspace query call to SORMHR ==== */ i__1 = jw - 1; sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info); lwk2 = (integer) work[1]; /* ==== Optimal workspace ==== */ lwkopt = jw + max(lwk1,lwk2); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (real) lwkopt; return 0; } *ns = 0; *nd = 0; work[1] = 1.f; if (*ktop > *kbot) { return 0; } if (*nw < 1) { return 0; } /* ==== Machine constants ==== */ safmin = slamch_("SAFE MINIMUM"); safmax = 1.f / safmin; slabad_(&safmin, &safmax); ulp = slamch_("PRECISION"); smlnum = safmin * ((real) (*n) / ulp); /* ==== Setup deflation window ==== */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); kwtop = *kbot - jw + 1; if (kwtop == *ktop) { s = 0.f; } else { s = h__[kwtop + (kwtop - 1) * h_dim1]; } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ sr[kwtop] = h__[kwtop + kwtop * h_dim1]; si[kwtop] = 0.f; *ns = 1; *nd = 0; /* Computing MAX */ r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], dabs( r__1)); if (dabs(s) <= dmax(r__2,r__3)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { h__[kwtop + (kwtop - 1) * h_dim1] = 0.f; } } work[1] = 1.f; return 0; } /* ==== Convert to spike-triangular form. (In case of a */ /* . rare QR failure, this routine continues to do */ /* . aggressive early deflation using that part of */ /* . the deflation window that converged using INFQR */ /* . here and there to keep track.) ==== */ slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt); i__1 = jw - 1; i__2 = *ldh + 1; i__3 = *ldt + 1; scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); /* ==== STREXC needs a clean margin near the diagonal ==== */ i__1 = jw - 3; for (j = 1; j <= i__1; ++j) { t[j + 2 + j * t_dim1] = 0.f; t[j + 3 + j * t_dim1] = 0.f; } if (jw > 2) { t[jw + (jw - 2) * t_dim1] = 0.f; } /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; L20: if (ilst <= *ns) { if (*ns == 1) { bulge = FALSE_; } else { bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f; } /* ==== Small spike tip test for deflation ==== */ if (! bulge) { /* ==== Real eigenvalue ==== */ foo = (r__1 = t[*ns + *ns * t_dim1], dabs(r__1)); if (foo == 0.f) { foo = dabs(s); } /* Computing MAX */ r__2 = smlnum, r__3 = ulp * foo; if ((r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)) <= dmax(r__2, r__3)) { /* ==== Deflatable ==== */ --(*ns); } else { /* ==== Undeflatable. Move it up out of the way. */ /* . (STREXC can not fail in this case.) ==== */ ifst = *ns; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ++ilst; } } else { /* ==== Complex conjugate pair ==== */ foo = (r__3 = t[*ns + *ns * t_dim1], dabs(r__3)) + sqrt((r__1 = t[ *ns + (*ns - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[* ns - 1 + *ns * t_dim1], dabs(r__2))); if (foo == 0.f) { foo = dabs(s); } /* Computing MAX */ r__3 = (r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)), r__4 = (r__2 = s * v[(*ns - 1) * v_dim1 + 1], dabs(r__2)); /* Computing MAX */ r__5 = smlnum, r__6 = ulp * foo; if (dmax(r__3,r__4) <= dmax(r__5,r__6)) { /* ==== Deflatable ==== */ *ns += -2; } else { /* ==== Undeflatable. Move them up out of the way. */ /* . Fortunately, STREXC does the right thing with */ /* . ILST in case of a rare exchange failure. ==== */ ifst = *ns; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ilst += 2; } } /* ==== End deflation detection loop ==== */ goto L20; } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s = 0.f; } if (*ns < jw) { /* ==== sorting diagonal blocks of T improves accuracy for */ /* . graded matrices. Bubble sort deals well with */ /* . exchange failures. ==== */ sorted = FALSE_; i__ = *ns + 1; L30: if (sorted) { goto L50; } sorted = TRUE_; kend = i__ - 1; i__ = infqr + 1; if (i__ == *ns) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { k = i__ + 1; } else { k = i__ + 2; } L40: if (k <= kend) { if (k == i__ + 1) { evi = (r__1 = t[i__ + i__ * t_dim1], dabs(r__1)); } else { evi = (r__3 = t[i__ + i__ * t_dim1], dabs(r__3)) + sqrt((r__1 = t[i__ + 1 + i__ * t_dim1], dabs(r__1))) * sqrt(( r__2 = t[i__ + (i__ + 1) * t_dim1], dabs(r__2))); } if (k == kend) { evk = (r__1 = t[k + k * t_dim1], dabs(r__1)); } else if (t[k + 1 + k * t_dim1] == 0.f) { evk = (r__1 = t[k + k * t_dim1], dabs(r__1)); } else { evk = (r__3 = t[k + k * t_dim1], dabs(r__3)) + sqrt((r__1 = t[ k + 1 + k * t_dim1], dabs(r__1))) * sqrt((r__2 = t[k + (k + 1) * t_dim1], dabs(r__2))); } if (evi >= evk) { i__ = k; } else { sorted = FALSE_; ifst = i__; ilst = k; strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); if (info == 0) { i__ = ilst; } else { i__ = k; } } if (i__ == kend) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { k = i__ + 1; } else { k = i__ + 2; } goto L40; } goto L30; L50: ; } /* ==== Restore shift/eigenvalue array from T ==== */ i__ = jw; L60: if (i__ >= infqr + 1) { if (i__ == infqr + 1) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.f; --i__; } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.f; --i__; } else { aa = t[i__ - 1 + (i__ - 1) * t_dim1]; cc = t[i__ + (i__ - 1) * t_dim1]; bb = t[i__ - 1 + i__ * t_dim1]; dd = t[i__ + i__ * t_dim1]; slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn); i__ += -2; } goto L60; } if (*ns < jw || s == 0.f) { if (*ns > 1 && s != 0.f) { /* ==== Reflect spike back into lower triangle ==== */ scopy_(ns, &v[v_offset], ldv, &work[1], &c__1); beta = work[1]; slarfg_(ns, &beta, &work[2], &c__1, &tau); work[1] = 1.f; i__1 = jw - 2; i__2 = jw - 2; slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); } /* ==== Copy updated reduced window into place ==== */ if (kwtop > 1) { h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; } slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh); i__1 = jw - 1; i__2 = *ldt + 1; i__3 = *ldh + 1; scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3); /* ==== Accumulate orthogonal matrix in order update */ /* . H and Z, if requested. ==== */ if (*ns > 1 && s != 0.f) { i__1 = *lwork - jw; sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info); } /* ==== Update vertical slab in H ==== */ if (*wantt) { ltop = 1; } else { ltop = *ktop; } i__1 = kwtop - 1; i__2 = *nv; for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = kwtop - krow; kln = min(i__3,i__4); sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv); slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); } /* ==== Update horizontal slab in H ==== */ if (*wantt) { i__2 = *n; i__1 = *nh; for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) { /* Computing MIN */ i__3 = *nh, i__4 = *n - kcol + 1; kln = min(i__3,i__4); sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt); slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); } } /* ==== Update vertical slab in Z ==== */ if (*wantz) { i__1 = *ihiz; i__2 = *nv; for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = *ihiz - krow + 1; kln = min(i__3,i__4); sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ wv_offset], ldwv); slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); } } } *nd = jw - *ns; /* . INFQR from the spike length takes care */ /* . of the case of a rare QR failure while */ /* . calculating eigenvalues of the deflation */ /* . window.) ==== */ *ns -= infqr; /* ==== Return optimal workspace. ==== */ work[1] = (real) lwkopt; /* ==== End of SLAQR2 ==== */ return 0; } /* slaqr2_ */
/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, integer *lwork, integer *info) { /* System generated locals */ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; /* Local variables */ integer i__, k; real aa, bb, cc, dd; integer ld; real cs; integer nh, it, ks, kt; real sn; integer ku, kv, ls, ns; real ss; integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; real swap; integer ktop; real zdum[1] /* was [1][1] */ ; integer kacc22, itmax, nsmax, nwmax, kwtop; extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slaqr3_(logical *, logical *, integer *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, integer *, real *, integer *), slaqr4_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, real *, integer *, integer *), slaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, integer *, real * , integer *, integer *, real *, integer *); integer nibble; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); char jbcmpz[2]; extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *); integer nwupbd; logical sorted; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ================================================================ */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . SLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== Exceptional deflation windows: try to cure rare */ /* . slow convergence by varying the size of the */ /* . deflation window after KEXNW iterations. ==== */ /* ==== Exceptional shifts: try to cure rare slow convergence */ /* . with ad-hoc exceptional shifts every KEXSH iterations. */ /* . ==== */ /* ==== The constants WILK1 and WILK2 are used to form the */ /* . exceptional shifts. ==== */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* ==== Quick return for N = 0: nothing to do. ==== */ if (*n == 0) { work[1] = 1.f; return 0; } if (*n <= 11) { /* ==== Tiny matrices must use SLAHQR. ==== */ lwkopt = 1; if (*lwork != -1) { slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & wi[1], iloz, ihiz, &z__[z_offset], ldz, info); } } else { /* ==== Use small bulge multi-shift QR with aggressive early */ /* . deflation on larger-than-tiny matrices. ==== */ /* ==== Hope for the best. ==== */ *info = 0; /* ==== Set up job flags for ILAENV. ==== */ if (*wantt) { *(unsigned char *)jbcmpz = 'S'; } else { *(unsigned char *)jbcmpz = 'E'; } if (*wantz) { *(unsigned char *)&jbcmpz[1] = 'V'; } else { *(unsigned char *)&jbcmpz[1] = 'N'; } /* ==== NWR = recommended deflation window size. At this */ /* . point, N .GT. NTINY = 11, so there is enough */ /* . subdiagonal workspace for NWR.GE.2 as required. */ /* . (In fact, there is enough subdiagonal space for */ /* . NWR.GE.3.) ==== */ nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nwr = max(2,nwr); /* Computing MIN */ i__1 = *ihi - *ilo + 1; i__2 = (*n - 1) / 3; i__1 = min(i__1,i__2); // ; expr subst nwr = min(i__1,nwr); /* ==== NSR = recommended number of simultaneous shifts. */ /* . At this point N .GT. NTINY = 11, so there is at */ /* . enough subdiagonal workspace for NSR to be even */ /* . and greater than or equal to two as required. ==== */ nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); /* Computing MIN */ i__1 = nsr, i__2 = (*n + 6) / 9; i__1 = min(i__1,i__2); i__2 = *ihi - *ilo; // ; expr subst nsr = min(i__1,i__2); /* Computing MAX */ i__1 = 2; i__2 = nsr - nsr % 2; // , expr subst nsr = max(i__1,i__2); /* ==== Estimate optimal workspace ==== */ /* ==== Workspace query call to SLAQR3 ==== */ i__1 = nwr + 1; slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], &c_n1); /* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */ /* Computing MAX */ i__1 = nsr * 3 / 2; i__2 = (integer) work[1]; // , expr subst lwkopt = max(i__1,i__2); /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (real) lwkopt; return 0; } /* ==== SLAHQR/SLAQR0 crossover point ==== */ nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nmin = max(11,nmin); /* ==== Nibble crossover point ==== */ nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); nibble = max(0,nibble); /* ==== Accumulate reflections during ttswp? Use block */ /* . 2-by-2 structure during matrix-matrix multiply? ==== */ kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork); kacc22 = max(0,kacc22); kacc22 = min(2,kacc22); /* ==== NWMAX = the largest possible deflation window for */ /* . which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n - 1) / 3; i__2 = *lwork / 2; // , expr subst nwmax = min(i__1,i__2); nw = nwmax; /* ==== NSMAX = the Largest number of simultaneous shifts */ /* . for which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n + 6) / 9; i__2 = (*lwork << 1) / 3; // , expr subst nsmax = min(i__1,i__2); nsmax -= nsmax % 2; /* ==== NDFL: an iteration count restarted at deflation. ==== */ ndfl = 1; /* ==== ITMAX = iteration limit ==== */ /* Computing MAX */ i__1 = 10; i__2 = *ihi - *ilo + 1; // , expr subst itmax = max(i__1,i__2) * 30; /* ==== Last row and column in the active block ==== */ kbot = *ihi; /* ==== Main Loop ==== */ i__1 = itmax; for (it = 1; it <= i__1; ++it) { /* ==== Done when KBOT falls below ILO ==== */ if (kbot < *ilo) { goto L90; } /* ==== Locate active block ==== */ i__2 = *ilo + 1; for (k = kbot; k >= i__2; --k) { if (h__[k + (k - 1) * h_dim1] == 0.f) { goto L20; } /* L10: */ } k = *ilo; L20: ktop = k; /* ==== Select deflation window size: */ /* . Typical Case: */ /* . If possible and advisable, nibble the entire */ /* . active block. If not, use size MIN(NWR,NWMAX) */ /* . or MIN(NWR+1,NWMAX) depending upon which has */ /* . the smaller corresponding subdiagonal entry */ /* . (a heuristic). */ /* . */ /* . Exceptional Case: */ /* . If there have been no deflations in KEXNW or */ /* . more iterations, then vary the deflation window */ /* . size. At first, because, larger windows are, */ /* . in general, more powerful than smaller ones, */ /* . rapidly increase the window to the maximum possible. */ /* . Then, gradually reduce the window size. ==== */ nh = kbot - ktop + 1; nwupbd = min(nh,nwmax); if (ndfl < 5) { nw = min(nwupbd,nwr); } else { /* Computing MIN */ i__2 = nwupbd; i__3 = nw << 1; // , expr subst nw = min(i__2,i__3); } if (nw < nwmax) { if (nw >= nh - 1) { nw = nh; } else { kwtop = kbot - nw + 1; if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], f2c_abs(r__1)) > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], f2c_abs(r__2))) { ++nw; } } } if (ndfl < 5) { ndec = -1; } else if (ndec >= 0 || nw >= nwupbd) { ++ndec; if (nw - ndec < 2) { ndec = 0; } nw -= ndec; } /* ==== Aggressive early deflation: */ /* . split workspace under the subdiagonal into */ /* . - an nw-by-nw work array V in the lower */ /* . left-hand-corner, */ /* . - an NW-by-at-least-NW-but-more-is-better */ /* . (NW-by-NHO) horizontal work array along */ /* . the bottom edge, */ /* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ /* . vertical work array along the left-hand-edge. */ /* . ==== */ kv = *n - nw + 1; kt = nw + 1; nho = *n - nw - 1 - kt + 1; kwv = nw + 2; nve = *n - nw - kwv + 1; /* ==== Aggressive early deflation ==== */ slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); /* ==== Adjust KBOT accounting for new deflations. ==== */ kbot -= ld; /* ==== KS points to the shifts. ==== */ ks = kbot - ls + 1; /* ==== Skip an expensive QR sweep if there is a (partly */ /* . heuristic) reason to expect that many eigenvalues */ /* . will deflate without it. Here, the QR sweep is */ /* . skipped if many eigenvalues have just been deflated */ /* . or if the remaining active block is small. */ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min( nmin,nwmax)) { /* ==== NS = nominal number of simultaneous shifts. */ /* . This may be lowered (slightly) if SLAQR3 */ /* . did not provide that many shifts. ==== */ /* Computing MIN */ /* Computing MAX */ i__4 = 2; i__5 = kbot - ktop; // , expr subst i__2 = min(nsmax,nsr); i__3 = max(i__4,i__5); // , expr subst ns = min(i__2,i__3); ns -= ns % 2; /* ==== If there have been no deflations */ /* . in a multiple of KEXSH iterations, */ /* . then try exceptional shifts. */ /* . Otherwise use shifts provided by */ /* . SLAQR3 above or from the eigenvalues */ /* . of a trailing principal submatrix. ==== */ if (ndfl % 6 == 0) { ks = kbot - ns + 1; /* Computing MAX */ i__3 = ks + 1; i__4 = ktop + 2; // , expr subst i__2 = max(i__3,i__4); for (i__ = kbot; i__ >= i__2; i__ += -2) { ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], f2c_abs(r__1)) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], f2c_abs(r__2)); aa = ss * .75f + h__[i__ + i__ * h_dim1]; bb = ss; cc = ss * -.4375f; dd = aa; slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] , &wr[i__], &wi[i__], &cs, &sn); /* L30: */ } if (ks == ktop) { wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; wi[ks + 1] = 0.f; wr[ks] = wr[ks + 1]; wi[ks] = wi[ks + 1]; } } else { /* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */ /* . SLAHQR on a trailing principal submatrix to */ /* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ /* . there is enough space below the subdiagonal */ /* . to fit an NS-by-NS scratch array.) ==== */ if (kbot - ks + 1 <= ns / 2) { ks = kbot - ns + 1; kt = *n - ns + 1; slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & h__[kt + h_dim1], ldh); if (ns > nmin) { slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &work[1], lwork, &inf); } else { slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &inf); } ks += inf; /* ==== In case of a rare QR failure use */ /* . eigenvalues of the trailing 2-by-2 */ /* . principal submatrix. ==== */ if (ks >= kbot) { aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; cc = h__[kbot + (kbot - 1) * h_dim1]; bb = h__[kbot - 1 + kbot * h_dim1]; dd = h__[kbot + kbot * h_dim1]; slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) ; ks = kbot - 1; } } if (kbot - ks + 1 > ns) { /* ==== Sort the shifts (Helps a little) */ /* . Bubble sort keeps complex conjugate */ /* . pairs together. ==== */ sorted = FALSE_; i__2 = ks + 1; for (k = kbot; k >= i__2; --k) { if (sorted) { goto L60; } sorted = TRUE_; i__3 = k - 1; for (i__ = ks; i__ <= i__3; ++i__) { if ((r__1 = wr[i__], f2c_abs(r__1)) + (r__2 = wi[ i__], f2c_abs(r__2)) < (r__3 = wr[i__ + 1] , f2c_abs(r__3)) + (r__4 = wi[i__ + 1], f2c_abs(r__4))) { sorted = FALSE_; swap = wr[i__]; wr[i__] = wr[i__ + 1]; wr[i__ + 1] = swap; swap = wi[i__]; wi[i__] = wi[i__ + 1]; wi[i__ + 1] = swap; } /* L40: */ } /* L50: */ } L60: ; } /* ==== Shuffle shifts into pairs of real shifts */ /* . and pairs of complex conjugate shifts */ /* . assuming complex conjugate shifts are */ /* . already adjacent to one another. (Yes, */ /* . they are.) ==== */ i__2 = ks + 2; for (i__ = kbot; i__ >= i__2; i__ += -2) { if (wi[i__] != -wi[i__ - 1]) { swap = wr[i__]; wr[i__] = wr[i__ - 1]; wr[i__ - 1] = wr[i__ - 2]; wr[i__ - 2] = swap; swap = wi[i__]; wi[i__] = wi[i__ - 1]; wi[i__ - 1] = wi[i__ - 2]; wi[i__ - 2] = swap; } /* L70: */ } } /* ==== If there are only two shifts and both are */ /* . real, then use only one. ==== */ if (kbot - ks + 1 == 2) { if (wi[kbot] == 0.f) { if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1], f2c_abs( r__1)) < (r__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], f2c_abs(r__2))) { wr[kbot - 1] = wr[kbot]; } else { wr[kbot] = wr[kbot - 1]; } } } /* ==== Use up to NS of the the smallest magnatiude */ /* . shifts. If there aren't NS shifts available, */ /* . then use them all, possibly dropping one to */ /* . make the number of shifts even. ==== */ /* Computing MIN */ i__2 = ns; i__3 = kbot - ks + 1; // , expr subst ns = min(i__2,i__3); ns -= ns % 2; ks = kbot - ns + 1; /* ==== Small-bulge multi-shift QR sweep: */ /* . split workspace under the subdiagonal into */ /* . - a KDU-by-KDU work array U in the lower */ /* . left-hand-corner, */ /* . - a KDU-by-at-least-KDU-but-more-is-better */ /* . (KDU-by-NHo) horizontal work array WH along */ /* . the bottom edge, */ /* . - and an at-least-KDU-but-more-is-better-by-KDU */ /* . (NVE-by-KDU) vertical work WV arrow along */ /* . the left-hand-edge. ==== */ kdu = ns * 3 - 3; ku = *n - kdu + 1; kwh = kdu + 1; nho = *n - kdu - 3 - (kdu + 1) + 1; kwv = kdu + 4; nve = *n - kdu - kwv + 1; /* ==== Small-bulge multi-shift QR sweep ==== */ slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], ldh); } /* ==== Note progress (or the lack of it). ==== */ if (ld > 0) { ndfl = 1; } else { ++ndfl; } /* ==== End of main loop ==== */ /* L80: */ } /* ==== Iteration limit exceeded. Set INFO to show where */ /* . the problem occurred and exit. ==== */ *info = kbot; L90: ; } /* ==== Return the optimal value of LWORK. ==== */ work[1] = (real) lwkopt; /* ==== End of SLAQR0 ==== */ return 0; }
/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__, integer *ldz, real *work, integer *lwork, integer *info, ftnlen job_len, ftnlen compz_len) { /* System generated locals */ address a__1[2]; integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4, i__5; real r__1, r__2; char ch__1[2]; /* Builtin functions */ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static integer i__, j, k, l; static real s[225] /* was [15][15] */, v[16]; static integer i1, i2, ii, nh, nr, ns, nv; static real vv[16]; static integer itn; static real tau; static integer its; static real ulp, tst1; static integer maxb; static real absw; static integer ierr; static real unfl, temp, ovfl; extern logical lsame_(char *, char *, ftnlen, ftnlen); extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); static integer itemp; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *, ftnlen); static logical initz, wantt; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static logical wantz; extern doublereal slapy2_(real *, real *); extern /* Subroutine */ int slabad_(real *, real *); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, real *); extern integer isamax_(integer *, real *, integer *); extern doublereal slanhs_(char *, integer *, real *, integer *, real *, ftnlen); extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *, ftnlen), slaset_(char *, integer *, integer *, real *, real *, real *, integer *, ftnlen), slarfx_(char *, integer *, integer *, real *, real *, real *, integer *, real *, ftnlen); static real smlnum; static logical lquery; /* -- LAPACK routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* June 30, 1999 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */ /* and, optionally, the matrices T and Z from the Schur decomposition */ /* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur */ /* form), and Z is the orthogonal matrix of Schur vectors. */ /* Optionally Z may be postmultiplied into an input orthogonal matrix Q, */ /* so that this routine can give the Schur factorization of a matrix A */ /* which has been reduced to the Hessenberg form H by the orthogonal */ /* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* = 'E': compute eigenvalues only; */ /* = 'S': compute eigenvalues and the Schur form T. */ /* COMPZ (input) CHARACTER*1 */ /* = 'N': no Schur vectors are computed; */ /* = 'I': Z is initialized to the unit matrix and the matrix Z */ /* of Schur vectors of H is returned; */ /* = 'V': Z must contain an orthogonal matrix Q on entry, and */ /* the product Q*Z is returned. */ /* N (input) INTEGER */ /* The order of the matrix H. N >= 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that H is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ /* set by a previous call to SGEBAL, and then passed to SGEHRD */ /* when the matrix output by SGEBAL is reduced to Hessenberg */ /* form. Otherwise ILO and IHI should be set to 1 and N */ /* respectively. */ /* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ /* H (input/output) REAL array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if JOB = 'S', H contains the upper quasi-triangular */ /* matrix T from the Schur decomposition (the Schur form); */ /* 2-by-2 diagonal blocks (corresponding to complex conjugate */ /* pairs of eigenvalues) are returned in standard form, with */ /* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', */ /* the contents of H are unspecified on exit. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH >= max(1,N). */ /* WR (output) REAL array, dimension (N) */ /* WI (output) REAL array, dimension (N) */ /* The real and imaginary parts, respectively, of the computed */ /* eigenvalues. If two eigenvalues are computed as a complex */ /* conjugate pair, they are stored in consecutive elements of */ /* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */ /* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the */ /* same order as on the diagonal of the Schur form returned in */ /* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */ /* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */ /* WI(i+1) = -WI(i). */ /* Z (input/output) REAL array, dimension (LDZ,N) */ /* If COMPZ = 'N': Z is not referenced. */ /* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */ /* contains the orthogonal matrix Z of the Schur vectors of H. */ /* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */ /* which is assumed to be equal to the unit matrix except for */ /* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */ /* Normally Q is the orthogonal matrix generated by SORGHR after */ /* the call to SGEHRD which formed the Hessenberg matrix H. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. */ /* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */ /* WORK (workspace/output) REAL array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= max(1,N). */ /* 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, SHSEQR failed to compute all of the */ /* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */ /* elements 1:ilo-1 and i+1:n of WR and WI contain those */ /* eigenvalues which have been successfully computed. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ wantt = lsame_(job, "S", (ftnlen)1, (ftnlen)1); initz = lsame_(compz, "I", (ftnlen)1, (ftnlen)1); wantz = initz || lsame_(compz, "V", (ftnlen)1, (ftnlen)1); *info = 0; work[1] = (real) max(1,*n); lquery = *lwork == -1; if (! lsame_(job, "E", (ftnlen)1, (ftnlen)1) && ! wantt) { *info = -1; } else if (! lsame_(compz, "N", (ftnlen)1, (ftnlen)1) && ! wantz) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -4; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) { *info = -11; } else if (*lwork < max(1,*n) && ! lquery) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("SHSEQR", &i__1, (ftnlen)6); return 0; } else if (lquery) { return 0; } /* Initialize Z, if necessary */ if (initz) { slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4); } /* Store the eigenvalues isolated by SGEBAL. */ i__1 = *ilo - 1; for (i__ = 1; i__ <= i__1; ++i__) { wr[i__] = h__[i__ + i__ * h_dim1]; wi[i__] = 0.f; /* L10: */ } i__1 = *n; for (i__ = *ihi + 1; i__ <= i__1; ++i__) { wr[i__] = h__[i__ + i__ * h_dim1]; wi[i__] = 0.f; /* L20: */ } /* Quick return if possible. */ if (*n == 0) { return 0; } if (*ilo == *ihi) { wr[*ilo] = h__[*ilo + *ilo * h_dim1]; wi[*ilo] = 0.f; return 0; } /* Set rows and columns ILO to IHI to zero below the first */ /* subdiagonal. */ i__1 = *ihi - 2; for (j = *ilo; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 2; i__ <= i__2; ++i__) { h__[i__ + j * h_dim1] = 0.f; /* L30: */ } /* L40: */ } nh = *ihi - *ilo + 1; /* Determine the order of the multi-shift QR algorithm to be used. */ /* Writing concatenation */ i__3[0] = 1, a__1[0] = job; i__3[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); ns = ilaenv_(&c__4, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, ( ftnlen)2); /* Writing concatenation */ i__3[0] = 1, a__1[0] = job; i__3[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); maxb = ilaenv_(&c__8, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, ( ftnlen)2); if (ns <= 2 || ns > nh || maxb >= nh) { /* Use the standard double-shift algorithm */ slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ 1], ilo, ihi, &z__[z_offset], ldz, info); return 0; } maxb = max(3,maxb); /* Computing MIN */ i__1 = min(ns,maxb); ns = min(i__1,15); /* Now 2 < NS <= MAXB < NH. */ /* Set machine-dependent constants for the stopping criterion. */ /* If norm(H) <= sqrt(OVFL), overflow should not occur. */ unfl = slamch_("Safe minimum", (ftnlen)12); ovfl = 1.f / unfl; slabad_(&unfl, &ovfl); ulp = slamch_("Precision", (ftnlen)9); smlnum = unfl * (nh / ulp); /* I1 and I2 are the indices of the first row and last column of H */ /* to which transformations must be applied. If eigenvalues only are */ /* being computed, I1 and I2 are set inside the main loop. */ if (wantt) { i1 = 1; i2 = *n; } /* ITN is the total number of multiple-shift QR iterations allowed. */ itn = nh * 30; /* The main loop begins here. I is the loop index and decreases from */ /* IHI to ILO in steps of at most MAXB. Each iteration of the loop */ /* works with the active submatrix in rows and columns L to I. */ /* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */ /* H(L,L-1) is negligible so that the matrix splits. */ i__ = *ihi; L50: l = *ilo; if (i__ < *ilo) { goto L170; } /* Perform multiple-shift QR iterations on rows and columns ILO to I */ /* until a submatrix of order at most MAXB splits off at the bottom */ /* because a subdiagonal element has become negligible. */ i__1 = itn; for (its = 0; its <= i__1; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i__; k >= i__2; --k) { tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2 = h__[k + k * h_dim1], dabs(r__2)); if (tst1 == 0.f) { i__4 = i__ - l + 1; tst1 = slanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1] , (ftnlen)1); } /* Computing MAX */ r__2 = ulp * tst1; if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2, smlnum)) { goto L70; } /* L60: */ } L70: l = k; if (l > *ilo) { /* H(L,L-1) is negligible. */ h__[l + (l - 1) * h_dim1] = 0.f; } /* Exit from loop if a submatrix of order <= MAXB has split off. */ if (l >= i__ - maxb + 1) { goto L160; } /* Now the active submatrix is in rows and columns L to I. If */ /* eigenvalues only are being computed, only the active submatrix */ /* need be transformed. */ if (! wantt) { i1 = l; i2 = i__; } if (its == 20 || its == 30) { /* Exceptional shifts. */ i__2 = i__; for (ii = i__ - ns + 1; ii <= i__2; ++ii) { wr[ii] = ((r__1 = h__[ii + (ii - 1) * h_dim1], dabs(r__1)) + ( r__2 = h__[ii + ii * h_dim1], dabs(r__2))) * 1.5f; wi[ii] = 0.f; /* L80: */ } } else { /* Use eigenvalues of trailing submatrix of order NS as shifts. */ slacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) * h_dim1], ldh, s, &c__15, (ftnlen)4); slahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ - ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr); if (ierr > 0) { /* If SLAHQR failed to compute all NS eigenvalues, use the */ /* unconverged diagonal elements as the remaining shifts. */ i__2 = ierr; for (ii = 1; ii <= i__2; ++ii) { wr[i__ - ns + ii] = s[ii + ii * 15 - 16]; wi[i__ - ns + ii] = 0.f; /* L90: */ } } } /* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */ /* where G is the Hessenberg submatrix H(L:I,L:I) and w is */ /* the vector of shifts (stored in WR and WI). The result is */ /* stored in the local array V. */ v[0] = 1.f; i__2 = ns + 1; for (ii = 2; ii <= i__2; ++ii) { v[ii - 1] = 0.f; /* L100: */ } nv = 1; i__2 = i__; for (j = i__ - ns + 1; j <= i__2; ++j) { if (wi[j] >= 0.f) { if (wi[j] == 0.f) { /* real shift */ i__4 = nv + 1; scopy_(&i__4, v, &c__1, vv, &c__1); i__4 = nv + 1; r__1 = -wr[j]; sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l * h_dim1], ldh, vv, &c__1, &r__1, v, &c__1, (ftnlen) 12); ++nv; } else if (wi[j] > 0.f) { /* complex conjugate pair of shifts */ i__4 = nv + 1; scopy_(&i__4, v, &c__1, vv, &c__1); i__4 = nv + 1; r__1 = wr[j] * -2.f; sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l * h_dim1], ldh, v, &c__1, &r__1, vv, &c__1, (ftnlen) 12); i__4 = nv + 1; itemp = isamax_(&i__4, vv, &c__1); /* Computing MAX */ r__2 = (r__1 = vv[itemp - 1], dabs(r__1)); temp = 1.f / dmax(r__2,smlnum); i__4 = nv + 1; sscal_(&i__4, &temp, vv, &c__1); absw = slapy2_(&wr[j], &wi[j]); temp = temp * absw * absw; i__4 = nv + 2; i__5 = nv + 1; sgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l * h_dim1], ldh, vv, &c__1, &temp, v, &c__1, (ftnlen) 12); nv += 2; } /* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, */ /* reset it to the unit vector. */ itemp = isamax_(&nv, v, &c__1); temp = (r__1 = v[itemp - 1], dabs(r__1)); if (temp == 0.f) { v[0] = 1.f; i__4 = nv; for (ii = 2; ii <= i__4; ++ii) { v[ii - 1] = 0.f; /* L110: */ } } else { temp = dmax(temp,smlnum); r__1 = 1.f / temp; sscal_(&nv, &r__1, v, &c__1); } } /* L120: */ } /* Multiple-shift QR step */ i__2 = i__ - 1; for (k = l; k <= i__2; ++k) { /* The first iteration of this loop determines a reflection G */ /* from the vector V and applies it from left and right to H, */ /* thus creating a nonzero bulge below the subdiagonal. */ /* Each subsequent iteration determines a reflection G to */ /* restore the Hessenberg form in the (K-1)th column, and thus */ /* chases the bulge one step toward the bottom of the active */ /* submatrix. NR is the order of G. */ /* Computing MIN */ i__4 = ns + 1, i__5 = i__ - k + 1; nr = min(i__4,i__5); if (k > l) { scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); } slarfg_(&nr, v, &v[1], &c__1, &tau); if (k > l) { h__[k + (k - 1) * h_dim1] = v[0]; i__4 = i__; for (ii = k + 1; ii <= i__4; ++ii) { h__[ii + (k - 1) * h_dim1] = 0.f; /* L130: */ } } v[0] = 1.f; /* Apply G from the left to transform the rows of the matrix in */ /* columns K to I2. */ i__4 = i2 - k + 1; slarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, & work[1], (ftnlen)4); /* Apply G from the right to transform the columns of the */ /* matrix in rows I1 to min(K+NR,I). */ /* Computing MIN */ i__5 = k + nr; i__4 = min(i__5,i__) - i1 + 1; slarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh, &work[1], (ftnlen)5); if (wantz) { /* Accumulate transformations in the matrix Z */ slarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1], ldz, &work[1], (ftnlen)5); } /* L140: */ } /* L150: */ } /* Failure to converge in remaining number of iterations */ *info = i__; return 0; L160: /* A submatrix of order <= MAXB in rows and columns L to I has split */ /* off. Use the double-shift QR algorithm to handle it. */ slahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, info); if (*info > 0) { return 0; } /* Decrement number of remaining iterations, and return to start of */ /* the main loop with a new value of I. */ itn -= its; i__ = l - 1; goto L50; L170: work[1] = (real) max(1,*n); return 0; /* End of SHSEQR */ } /* shseqr_ */
/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__, integer *ldz, real *work, integer *lwork, integer *info) { /* System generated locals */ address a__1[2]; integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; real r__1; char ch__1[2]; /* Builtin functions */ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ integer i__; #ifdef LAPACK_DISABLE_MEMORY_HOGS real hl[1] /* was [49][49] */; /** This function uses too much memory, so we stopped allocating the memory * above and assert false here. */ assert(0 && "shseqr_ was called. This function allocates too much" " memory and has been disabled."); #else real hl[2401] /* was [49][49] */; #endif integer kbot, nmin; extern logical lsame_(char *, char *); logical initz; real workl[49]; logical wantt, wantz; extern /* Subroutine */ int slaqr0_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, real *, integer *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *); logical lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SHSEQR computes the eigenvalues of a Hessenberg matrix H */ /* and, optionally, the matrices T and Z from the Schur decomposition */ /* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ /* Schur form), and Z is the orthogonal matrix of Schur vectors. */ /* Optionally Z may be postmultiplied into an input orthogonal */ /* matrix Q so that this routine can give the Schur factorization */ /* of a matrix A which has been reduced to the Hessenberg form H */ /* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ /* Arguments */ /* ========= */ /* JOB (input) CHARACTER*1 */ /* = 'E': compute eigenvalues only; */ /* = 'S': compute eigenvalues and the Schur form T. */ /* COMPZ (input) CHARACTER*1 */ /* = 'N': no Schur vectors are computed; */ /* = 'I': Z is initialized to the unit matrix and the matrix Z */ /* of Schur vectors of H is returned; */ /* = 'V': Z must contain an orthogonal matrix Q on entry, and */ /* the product Q*Z is returned. */ /* N (input) INTEGER */ /* The order of the matrix H. N .GE. 0. */ /* ILO (input) INTEGER */ /* IHI (input) INTEGER */ /* It is assumed that H is already upper triangular in rows */ /* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ /* set by a previous call to SGEBAL, and then passed to SGEHRD */ /* when the matrix output by SGEBAL is reduced to Hessenberg */ /* form. Otherwise ILO and IHI should be set to 1 and N */ /* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ /* If N = 0, then ILO = 1 and IHI = 0. */ /* H (input/output) REAL array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if INFO = 0 and JOB = 'S', then H contains the */ /* upper quasi-triangular matrix T from the Schur decomposition */ /* (the Schur form); 2-by-2 diagonal blocks (corresponding to */ /* complex conjugate pairs of eigenvalues) are returned in */ /* standard form, with H(i,i) = H(i+1,i+1) and */ /* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */ /* contents of H are unspecified on exit. (The output value of */ /* H when INFO.GT.0 is given under the description of INFO */ /* below.) */ /* Unlike earlier versions of SHSEQR, this subroutine may */ /* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */ /* or j = IHI+1, IHI+2, ... N. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH .GE. max(1,N). */ /* WR (output) REAL array, dimension (N) */ /* WI (output) REAL array, dimension (N) */ /* The real and imaginary parts, respectively, of the computed */ /* eigenvalues. If two eigenvalues are computed as a complex */ /* conjugate pair, they are stored in consecutive elements of */ /* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */ /* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */ /* the same order as on the diagonal of the Schur form returned */ /* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */ /* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ /* WI(i+1) = -WI(i). */ /* Z (input/output) REAL array, dimension (LDZ,N) */ /* If COMPZ = 'N', Z is not referenced. */ /* If COMPZ = 'I', on entry Z need not be set and on exit, */ /* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */ /* vectors of H. If COMPZ = 'V', on entry Z must contain an */ /* N-by-N matrix Q, which is assumed to be equal to the unit */ /* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */ /* if INFO = 0, Z contains Q*Z. */ /* Normally Q is the orthogonal matrix generated by SORGHR */ /* after the call to SGEHRD which formed the Hessenberg matrix */ /* H. (The output value of Z when INFO.GT.0 is given under */ /* the description of INFO below.) */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. if COMPZ = 'I' or */ /* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */ /* WORK (workspace/output) REAL array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns an estimate of */ /* the optimal value for LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK .GE. max(1,N) */ /* is sufficient and delivers very good and sometimes */ /* optimal performance. However, LWORK as large as 11*N */ /* may be required for optimal performance. A workspace */ /* query is recommended to determine the optimal workspace */ /* size. */ /* If LWORK = -1, then SHSEQR does a workspace query. */ /* In this case, SHSEQR checks the input parameters and */ /* estimates the optimal workspace size for the given */ /* values of N, ILO and IHI. The estimate is returned */ /* in WORK(1). No error message related to LWORK is */ /* issued by XERBLA. Neither H nor Z are accessed. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* .LT. 0: if INFO = -i, the i-th argument had an illegal */ /* value */ /* .GT. 0: if INFO = i, SHSEQR failed to compute all of */ /* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ /* and WI contain those eigenvalues which have been */ /* successfully computed. (Failures are rare.) */ /* If INFO .GT. 0 and JOB = 'E', then on exit, the */ /* remaining unconverged eigenvalues are the eigen- */ /* values of the upper Hessenberg matrix rows and */ /* columns ILO through INFO of the final, output */ /* value of H. */ /* If INFO .GT. 0 and JOB = 'S', then on exit */ /* (*) (initial value of H)*U = U*(final value of H) */ /* where U is an orthogonal matrix. The final */ /* value of H is upper Hessenberg and quasi-triangular */ /* in rows and columns INFO+1 through IHI. */ /* If INFO .GT. 0 and COMPZ = 'V', then on exit */ /* (final value of Z) = (initial value of Z)*U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of JOB.) */ /* If INFO .GT. 0 and COMPZ = 'I', then on exit */ /* (final value of Z) = U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of JOB.) */ /* If INFO .GT. 0 and COMPZ = 'N', then Z is not */ /* accessed. */ /* ================================================================ */ /* Default values supplied by */ /* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ /* It is suggested that these defaults be adjusted in order */ /* to attain best performance in each particular */ /* computational environment. */ /* ISPEC=12: The SLAHQR vs SLAQR0 crossover point. */ /* Default: 75. (Must be at least 11.) */ /* ISPEC=13: Recommended deflation window size. */ /* This depends on ILO, IHI and NS. NS is the */ /* number of simultaneous shifts returned */ /* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ /* The default for (IHI-ILO+1).LE.500 is NS. */ /* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */ /* ISPEC=14: Nibble crossover point. (See IPARMQ for */ /* details.) Default: 14% of deflation window */ /* size. */ /* ISPEC=15: Number of simultaneous shifts in a multishift */ /* QR iteration. */ /* If IHI-ILO+1 is ... */ /* greater than ...but less ... the */ /* or equal to ... than default is */ /* 1 30 NS = 2(+) */ /* 30 60 NS = 4(+) */ /* 60 150 NS = 10(+) */ /* 150 590 NS = ** */ /* 590 3000 NS = 64 */ /* 3000 6000 NS = 128 */ /* 6000 infinity NS = 256 */ /* (+) By default some or all matrices of this order */ /* are passed to the implicit double shift routine */ /* SLAHQR and this parameter is ignored. See */ /* ISPEC=12 above and comments in IPARMQ for */ /* details. */ /* (**) The asterisks (**) indicate an ad-hoc */ /* function of N increasing from 10 to 64. */ /* ISPEC=16: Select structured matrix multiply. */ /* If the number of simultaneous shifts (specified */ /* by ISPEC=15) is less than 14, then the default */ /* for ISPEC=16 is 0. Otherwise the default for */ /* ISPEC=16 is 2. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* References: */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ /* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ /* 929--947, 2002. */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ /* of Matrix Analysis, volume 23, pages 948--973, 2002. */ /* ================================================================ */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . SLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== NL allocates some local workspace to help small matrices */ /* . through a rare SLAHQR failure. NL .GT. NTINY = 11 is */ /* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */ /* . mended. (The default value of NMIN is 75.) Using NL = 49 */ /* . allows up to six simultaneous shifts and a 16-by-16 */ /* . deflation window. ==== */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Decode and check the input parameters. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ wantt = lsame_(job, "S"); initz = lsame_(compz, "I"); wantz = initz || lsame_(compz, "V"); work[1] = (real) max(1,*n); lquery = *lwork == -1; *info = 0; if (! lsame_(job, "E") && ! wantt) { *info = -1; } else if (! lsame_(compz, "N") && ! wantz) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ilo < 1 || *ilo > max(1,*n)) { *info = -4; } else if (*ihi < min(*ilo,*n) || *ihi > *n) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) { *info = -11; } else if (*lwork < max(1,*n) && ! lquery) { *info = -13; } if (*info != 0) { /* ==== Quick return in case of invalid argument. ==== */ i__1 = -(*info); xerbla_("SHSEQR", &i__1); return 0; } else if (*n == 0) { /* ==== Quick return in case N = 0; nothing to do. ==== */ return 0; } else if (lquery) { /* ==== Quick return in case of a workspace query ==== */ slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ r__1 = (real) max(1,*n); work[1] = dmax(r__1,work[1]); return 0; } else { /* ==== copy eigenvalues isolated by SGEBAL ==== */ i__1 = *ilo - 1; for (i__ = 1; i__ <= i__1; ++i__) { wr[i__] = h__[i__ + i__ * h_dim1]; wi[i__] = 0.f; /* L10: */ } i__1 = *n; for (i__ = *ihi + 1; i__ <= i__1; ++i__) { wr[i__] = h__[i__ + i__ * h_dim1]; wi[i__] = 0.f; /* L20: */ } /* ==== Initialize Z, if requested ==== */ if (initz) { slaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz) ; } /* ==== Quick return if possible ==== */ if (*ilo == *ihi) { wr[*ilo] = h__[*ilo + *ilo * h_dim1]; wi[*ilo] = 0.f; return 0; } /* ==== SLAHQR/SLAQR0 crossover point ==== */ /* Writing concatenation */ i__2[0] = 1, a__1[0] = job; i__2[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); nmin = ilaenv_(&c__12, "SHSEQR", ch__1, n, ilo, ihi, lwork); nmin = max(11,nmin); /* ==== SLAQR0 for big matrices; SLAHQR for small ones ==== */ if (*n > nmin) { slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Small matrix ==== */ slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, info); if (*info > 0) { /* ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds */ /* . when SLAHQR fails. ==== */ kbot = *info; if (*n >= 49) { /* ==== Larger matrices have enough subdiagonal scratch */ /* . space to call SLAQR0 directly. ==== */ slaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Tiny matrices don't have enough subdiagonal */ /* . scratch space to benefit from SLAQR0. Hence, */ /* . tiny matrices must be copied into a larger */ /* . array before calling SLAQR0. ==== */ slacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); hl[*n + 1 + *n * 49 - 50] = 0.f; i__1 = 49 - *n; slaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * 49 - 49], &c__49); slaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, workl, &c__49, info); if (wantt || *info != 0) { slacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); } } } } /* ==== Clear out the trash, if necessary. ==== */ if ((wantt || *info != 0) && *n > 2) { i__1 = *n - 2; i__3 = *n - 2; slaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); } /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ r__1 = (real) max(1,*n); work[1] = dmax(r__1,work[1]); } /* ==== End of SHSEQR ==== */ return 0; } /* shseqr_ */