/* Subroutine */ int slarre_(char* range, integer* n, real* vl, real* vu, integer* il, integer* iu, real* d__, real* e, real* e2, real* rtol1, real* rtol2, real* spltol, integer* nsplit, integer* isplit, integer * m, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, real* pivmin, real* work, integer* iwork, integer* info) { /* System generated locals */ integer i__1, i__2; real r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal), log(doublereal); /* Local variables */ integer i__, j; real s1, s2; integer mb; real gl; integer in, mm; real gu; integer cnt; real eps, tau, tmp, rtl; integer cnt1, cnt2; real tmp1, eabs; integer iend, jblk; real eold; integer indl; real dmax__, emax; integer wend, idum, indu; real rtol; integer iseed[4]; real avgap, sigma; extern logical lsame_(char*, char*); integer iinfo; logical norep; extern /* Subroutine */ int scopy_(integer*, real*, integer*, real*, integer*), slasq2_(integer*, real*, integer*); integer ibegin; logical forceb; integer irange; real sgndef; extern doublereal slamch_(char*); integer wbegin; real safmin, spdiam; extern /* Subroutine */ int slarra_(integer*, real*, real*, real*, real*, real*, integer*, integer*, integer*); logical usedqd; real clwdth, isleft; extern /* Subroutine */ int slarrb_(integer*, real*, real*, integer*, integer*, real*, real*, integer*, real*, real*, real*, real*, integer*, real*, real*, integer*, integer*), slarrc_( char*, integer*, real*, real*, real*, real*, real*, integer*, integer*, integer*, integer*), slarrd_(char *, char*, integer*, real*, real*, integer*, integer*, real * , real*, real*, real*, real*, real*, integer*, integer*, integer*, real*, real*, real*, real*, integer*, integer*, real*, integer*, integer*), slarrk_(integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); real isrght, bsrtol, dpivot; extern /* Subroutine */ int slarnv_(integer*, integer*, integer*, real *); /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* To find the desired eigenvalues of a given real symmetric */ /* tridiagonal matrix T, SLARRE sets any "small" off-diagonal */ /* elements to zero, and for each unreduced block T_i, it finds */ /* (a) a suitable shift at one end of the block's spectrum, */ /* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */ /* (c) eigenvalues of each L_i D_i L_i^T. */ /* The representations and eigenvalues found are then used by */ /* SSTEMR to compute the eigenvectors of T. */ /* The accuracy varies depending on whether bisection is used to */ /* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to */ /* conpute all and then discard any unwanted one. */ /* As an added benefit, SLARRE also outputs the n */ /* Gerschgorin intervals for the matrices L_i D_i L_i^T. */ /* Arguments */ /* ========= */ /* RANGE (input) CHARACTER */ /* = 'A': ("All") all eigenvalues will be found. */ /* = 'V': ("Value") all eigenvalues in the half-open interval */ /* (VL, VU] will be found. */ /* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ /* entire matrix) will be found. */ /* N (input) INTEGER */ /* The order of the matrix. N > 0. */ /* VL (input/output) REAL */ /* VU (input/output) REAL */ /* If RANGE='V', the lower and upper bounds for the eigenvalues. */ /* Eigenvalues less than or equal to VL, or greater than VU, */ /* will not be returned. VL < VU. */ /* If RANGE='I' or ='A', SLARRE computes bounds on the desired */ /* part of the spectrum. */ /* IL (input) INTEGER */ /* IU (input) INTEGER */ /* If RANGE='I', the indices (in ascending order) of the */ /* smallest and largest eigenvalues to be returned. */ /* 1 <= IL <= IU <= N. */ /* D (input/output) REAL array, dimension (N) */ /* On entry, the N diagonal elements of the tridiagonal */ /* matrix T. */ /* On exit, the N diagonal elements of the diagonal */ /* matrices D_i. */ /* E (input/output) REAL array, dimension (N) */ /* On entry, the first (N-1) entries contain the subdiagonal */ /* elements of the tridiagonal matrix T; E(N) need not be set. */ /* On exit, E contains the subdiagonal elements of the unit */ /* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */ /* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */ /* E2 (input/output) REAL array, dimension (N) */ /* On entry, the first (N-1) entries contain the SQUARES of the */ /* subdiagonal elements of the tridiagonal matrix T; */ /* E2(N) need not be set. */ /* On exit, the entries E2( ISPLIT( I ) ), */ /* 1 <= I <= NSPLIT, have been set to zero */ /* RTOL1 (input) REAL */ /* RTOL2 (input) REAL */ /* Parameters for bisection. */ /* An interval [LEFT,RIGHT] has converged if */ /* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ /* SPLTOL (input) REAL */ /* The threshold for splitting. */ /* NSPLIT (output) INTEGER */ /* The number of blocks T splits into. 1 <= NSPLIT <= N. */ /* ISPLIT (output) INTEGER array, dimension (N) */ /* The splitting points, at which T breaks up into blocks. */ /* The first block consists of rows/columns 1 to ISPLIT(1), */ /* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ /* etc., and the NSPLIT-th consists of rows/columns */ /* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ /* M (output) INTEGER */ /* The total number of eigenvalues (of all L_i D_i L_i^T) */ /* found. */ /* W (output) REAL array, dimension (N) */ /* The first M elements contain the eigenvalues. The */ /* eigenvalues of each of the blocks, L_i D_i L_i^T, are */ /* sorted in ascending order ( SLARRE may use the */ /* remaining N-M elements as workspace). */ /* WERR (output) REAL array, dimension (N) */ /* The error bound on the corresponding eigenvalue in W. */ /* WGAP (output) REAL array, dimension (N) */ /* The separation from the right neighbor eigenvalue in W. */ /* The gap is only with respect to the eigenvalues of the same block */ /* as each block has its own representation tree. */ /* Exception: at the right end of a block we store the left gap */ /* IBLOCK (output) INTEGER array, dimension (N) */ /* The indices of the blocks (submatrices) associated with the */ /* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ /* W(i) belongs to the first block from the top, =2 if W(i) */ /* belongs to the second block, etc. */ /* INDEXW (output) INTEGER array, dimension (N) */ /* The indices of the eigenvalues within each block (submatrix); */ /* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ /* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */ /* GERS (output) REAL array, dimension (2*N) */ /* The N Gerschgorin intervals (the i-th Gerschgorin interval */ /* is (GERS(2*i-1), GERS(2*i)). */ /* PIVMIN (output) DOUBLE PRECISION */ /* The minimum pivot in the Sturm sequence for T. */ /* WORK (workspace) REAL array, dimension (6*N) */ /* Workspace. */ /* IWORK (workspace) INTEGER array, dimension (5*N) */ /* Workspace. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* > 0: A problem occured in SLARRE. */ /* < 0: One of the called subroutines signaled an internal problem. */ /* Needs inspection of the corresponding parameter IINFO */ /* for further information. */ /* =-1: Problem in SLARRD. */ /* = 2: No base representation could be found in MAXTRY iterations. */ /* Increasing MAXTRY and recompilation might be a remedy. */ /* =-3: Problem in SLARRB when computing the refined root */ /* representation for SLASQ2. */ /* =-4: Problem in SLARRB when preforming bisection on the */ /* desired part of the spectrum. */ /* =-5: Problem in SLASQ2. */ /* =-6: Problem in SLASQ2. */ /* Further Details */ /* The base representations are required to suffer very little */ /* element growth and consequently define all their eigenvalues to */ /* high relative accuracy. */ /* =============== */ /* Based on contributions by */ /* Beresford Parlett, University of California, Berkeley, USA */ /* Jim Demmel, University of California, Berkeley, USA */ /* Inderjit Dhillon, University of Texas, Austin, USA */ /* Osni Marques, LBNL/NERSC, USA */ /* Christof Voemel, University of California, Berkeley, USA */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --iwork; --work; --gers; --indexw; --iblock; --wgap; --werr; --w; --isplit; --e2; --e; --d__; /* Function Body */ *info = 0; /* Decode RANGE */ if (lsame_(range, "A")) { irange = 1; } else if (lsame_(range, "V")) { irange = 3; } else if (lsame_(range, "I")) { irange = 2; } *m = 0; /* Get machine constants */ safmin = slamch_("S"); eps = slamch_("P"); /* Set parameters */ rtl = eps * 100.f; /* If one were ever to ask for less initial precision in BSRTOL, */ /* one should keep in mind that for the subset case, the extremal */ /* eigenvalues must be at least as accurate as the current setting */ /* (eigenvalues in the middle need not as much accuracy) */ bsrtol = sqrt(eps) * 5e-4f; /* Treat case of 1x1 matrix for quick return */ if (*n == 1) { if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu || irange == 2 && *il == 1 && *iu == 1) { *m = 1; w[1] = d__[1]; /* The computation error of the eigenvalue is zero */ werr[1] = 0.f; wgap[1] = 0.f; iblock[1] = 1; indexw[1] = 1; gers[1] = d__[1]; gers[2] = d__[1]; } /* store the shift for the initial RRR, which is zero in this case */ e[1] = 0.f; return 0; } /* General case: tridiagonal matrix of order > 1 */ /* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */ /* Compute maximum off-diagonal entry and pivmin. */ gl = d__[1]; gu = d__[1]; eold = 0.f; emax = 0.f; e[*n] = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { werr[i__] = 0.f; wgap[i__] = 0.f; eabs = (r__1 = e[i__], dabs(r__1)); if (eabs >= emax) { emax = eabs; } tmp1 = eabs + eold; gers[(i__ << 1) - 1] = d__[i__] - tmp1; /* Computing MIN */ r__1 = gl, r__2 = gers[(i__ << 1) - 1]; gl = dmin(r__1, r__2); gers[i__ * 2] = d__[i__] + tmp1; /* Computing MAX */ r__1 = gu, r__2 = gers[i__ * 2]; gu = dmax(r__1, r__2); eold = eabs; /* L5: */ } /* The minimum pivot allowed in the Sturm sequence for T */ /* Computing MAX */ /* Computing 2nd power */ r__3 = emax; r__1 = 1.f, r__2 = r__3 * r__3; *pivmin = safmin * dmax(r__1, r__2); /* Compute spectral diameter. The Gerschgorin bounds give an */ /* estimate that is wrong by at most a factor of SQRT(2) */ spdiam = gu - gl; /* Compute splitting points */ slarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], & iinfo); /* Can force use of bisection instead of faster DQDS. */ /* Option left in the code for future multisection work. */ forceb = FALSE_; if (irange == 1 && ! forceb) { /* Set interval [VL,VU] that contains all eigenvalues */ *vl = gl; *vu = gu; } else { /* We call SLARRD to find crude approximations to the eigenvalues */ /* in the desired range. In case IRANGE = INDRNG, we also obtain the */ /* interval (VL,VU] that contains all the wanted eigenvalues. */ /* An interval [LEFT,RIGHT] has converged if */ /* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */ /* SLARRD needs a WORK of size 4*N, IWORK of size 3*N */ slarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[ 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1], vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo); if (iinfo != 0) { *info = -1; return 0; } /* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */ i__1 = *n; for (i__ = mm + 1; i__ <= i__1; ++i__) { w[i__] = 0.f; werr[i__] = 0.f; iblock[i__] = 0; indexw[i__] = 0; /* L14: */ } } /* ** */ /* Loop over unreduced blocks */ ibegin = 1; wbegin = 1; i__1 = *nsplit; for (jblk = 1; jblk <= i__1; ++jblk) { iend = isplit[jblk]; in = iend - ibegin + 1; /* 1 X 1 block */ if (in == 1) { if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin] <= *vu || irange == 2 && iblock[wbegin] == jblk) { ++(*m); w[*m] = d__[ibegin]; werr[*m] = 0.f; /* The gap for a single block doesn't matter for the later */ /* algorithm and is assigned an arbitrary large value */ wgap[*m] = 0.f; iblock[*m] = jblk; indexw[*m] = 1; ++wbegin; } /* E( IEND ) holds the shift for the initial RRR */ e[iend] = 0.f; ibegin = iend + 1; goto L170; } /* Blocks of size larger than 1x1 */ /* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */ e[iend] = 0.f; /* Find local outer bounds GL,GU for the block */ gl = d__[ibegin]; gu = d__[ibegin]; i__2 = iend; for (i__ = ibegin; i__ <= i__2; ++i__) { /* Computing MIN */ r__1 = gers[(i__ << 1) - 1]; gl = dmin(r__1, gl); /* Computing MAX */ r__1 = gers[i__ * 2]; gu = dmax(r__1, gu); /* L15: */ } spdiam = gu - gl; if (!(irange == 1 && ! forceb)) { /* Count the number of eigenvalues in the current block. */ mb = 0; i__2 = mm; for (i__ = wbegin; i__ <= i__2; ++i__) { if (iblock[i__] == jblk) { ++mb; } else { goto L21; } /* L20: */ } L21: if (mb == 0) { /* No eigenvalue in the current block lies in the desired range */ /* E( IEND ) holds the shift for the initial RRR */ e[iend] = 0.f; ibegin = iend + 1; goto L170; } else { /* Decide whether dqds or bisection is more efficient */ usedqd = (real) mb > in * .5f && ! forceb; wend = wbegin + mb - 1; /* Calculate gaps for the current block */ /* In later stages, when representations for individual */ /* eigenvalues are different, we use SIGMA = E( IEND ). */ sigma = 0.f; i__2 = wend - 1; for (i__ = wbegin; i__ <= i__2; ++i__) { /* Computing MAX */ r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[i__]); wgap[i__] = dmax(r__1, r__2); /* L30: */ } /* Computing MAX */ r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); wgap[wend] = dmax(r__1, r__2); /* Find local index of the first and last desired evalue. */ indl = indexw[wbegin]; indu = indexw[wend]; } } if (irange == 1 && ! forceb || usedqd) { /* Case of DQDS */ /* Find approximations to the extremal eigenvalues of the block */ slarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & rtl, &tmp, &tmp1, &iinfo); if (iinfo != 0) { *info = -1; return 0; } /* Computing MAX */ r__2 = gl, r__3 = tmp - tmp1 - eps * 100.f * (r__1 = tmp - tmp1, dabs(r__1)); isleft = dmax(r__2, r__3); slarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & rtl, &tmp, &tmp1, &iinfo); if (iinfo != 0) { *info = -1; return 0; } /* Computing MIN */ r__2 = gu, r__3 = tmp + tmp1 + eps * 100.f * (r__1 = tmp + tmp1, dabs(r__1)); isrght = dmin(r__2, r__3); /* Improve the estimate of the spectral diameter */ spdiam = isrght - isleft; } else { /* Case of bisection */ /* Find approximations to the wanted extremal eigenvalues */ /* Computing MAX */ r__2 = gl, r__3 = w[wbegin] - werr[wbegin] - eps * 100.f * (r__1 = w[wbegin] - werr[wbegin], dabs(r__1)); isleft = dmax(r__2, r__3); /* Computing MIN */ r__2 = gu, r__3 = w[wend] + werr[wend] + eps * 100.f * (r__1 = w[ wend] + werr[wend], dabs(r__1)); isrght = dmin(r__2, r__3); } /* Decide whether the base representation for the current block */ /* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */ /* should be on the left or the right end of the current block. */ /* The strategy is to shift to the end which is "more populated" */ /* Furthermore, decide whether to use DQDS for the computation of */ /* the eigenvalue approximations at the end of SLARRE or bisection. */ /* dqds is chosen if all eigenvalues are desired or the number of */ /* eigenvalues to be computed is large compared to the blocksize. */ if (irange == 1 && ! forceb) { /* If all the eigenvalues have to be computed, we use dqd */ usedqd = TRUE_; /* INDL is the local index of the first eigenvalue to compute */ indl = 1; indu = in; /* MB = number of eigenvalues to compute */ mb = in; wend = wbegin + mb - 1; /* Define 1/4 and 3/4 points of the spectrum */ s1 = isleft + spdiam * .25f; s2 = isrght - spdiam * .25f; } else { /* SLARRD has computed IBLOCK and INDEXW for each eigenvalue */ /* approximation. */ /* choose sigma */ if (usedqd) { s1 = isleft + spdiam * .25f; s2 = isrght - spdiam * .25f; } else { tmp = dmin(isrght, *vu) - dmax(isleft, *vl); s1 = dmax(isleft, *vl) + tmp * .25f; s2 = dmin(isrght, *vu) - tmp * .25f; } } /* Compute the negcount at the 1/4 and 3/4 points */ if (mb > 1) { slarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, & cnt, &cnt1, &cnt2, &iinfo); } if (mb == 1) { sigma = gl; sgndef = 1.f; } else if (cnt1 - indl >= indu - cnt2) { if (irange == 1 && ! forceb) { sigma = dmax(isleft, gl); } else if (usedqd) { /* use Gerschgorin bound as shift to get pos def matrix */ /* for dqds */ sigma = isleft; } else { /* use approximation of the first desired eigenvalue of the */ /* block as shift */ sigma = dmax(isleft, *vl); } sgndef = 1.f; } else { if (irange == 1 && ! forceb) { sigma = dmin(isrght, gu); } else if (usedqd) { /* use Gerschgorin bound as shift to get neg def matrix */ /* for dqds */ sigma = isrght; } else { /* use approximation of the first desired eigenvalue of the */ /* block as shift */ sigma = dmin(isrght, *vu); } sgndef = -1.f; } /* An initial SIGMA has been chosen that will be used for computing */ /* T - SIGMA I = L D L^T */ /* Define the increment TAU of the shift in case the initial shift */ /* needs to be refined to obtain a factorization with not too much */ /* element growth. */ if (usedqd) { /* The initial SIGMA was to the outer end of the spectrum */ /* the matrix is definite and we need not retreat. */ tau = spdiam * eps * *n + *pivmin * 2.f; } else { if (mb > 1) { clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin]; avgap = (r__1 = clwdth / (real)(wend - wbegin), dabs(r__1)); if (sgndef == 1.f) { /* Computing MAX */ r__1 = wgap[wbegin]; tau = dmax(r__1, avgap) * .5f; /* Computing MAX */ r__1 = tau, r__2 = werr[wbegin]; tau = dmax(r__1, r__2); } else { /* Computing MAX */ r__1 = wgap[wend - 1]; tau = dmax(r__1, avgap) * .5f; /* Computing MAX */ r__1 = tau, r__2 = werr[wend]; tau = dmax(r__1, r__2); } } else { tau = werr[wbegin]; } } for (idum = 1; idum <= 6; ++idum) { /* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */ /* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */ /* pivots in WORK(2*IN+1:3*IN) */ dpivot = d__[ibegin] - sigma; work[1] = dpivot; dmax__ = dabs(work[1]); j = ibegin; i__2 = in - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[(in << 1) + i__] = 1.f / work[i__]; tmp = e[j] * work[(in << 1) + i__]; work[in + i__] = tmp; dpivot = d__[j + 1] - sigma - tmp * e[j]; work[i__ + 1] = dpivot; /* Computing MAX */ r__1 = dmax__, r__2 = dabs(dpivot); dmax__ = dmax(r__1, r__2); ++j; /* L70: */ } /* check for element growth */ if (dmax__ > spdiam * 64.f) { norep = TRUE_; } else { norep = FALSE_; } if (usedqd && ! norep) { /* Ensure the definiteness of the representation */ /* All entries of D (of L D L^T) must have the same sign */ i__2 = in; for (i__ = 1; i__ <= i__2; ++i__) { tmp = sgndef * work[i__]; if (tmp < 0.f) { norep = TRUE_; } /* L71: */ } } if (norep) { /* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */ /* shift which makes the matrix definite. So we should end up */ /* here really only in the case of IRANGE = VALRNG or INDRNG. */ if (idum == 5) { if (sgndef == 1.f) { /* The fudged Gerschgorin shift should succeed */ sigma = gl - spdiam * 2.f * eps * *n - *pivmin * 4.f; } else { sigma = gu + spdiam * 2.f * eps * *n + *pivmin * 4.f; } } else { sigma -= sgndef * tau; tau *= 2.f; } } else { /* an initial RRR is found */ goto L83; } /* L80: */ } /* if the program reaches this point, no base representation could be */ /* found in MAXTRY iterations. */ *info = 2; return 0; L83: /* At this point, we have found an initial base representation */ /* T - SIGMA I = L D L^T with not too much element growth. */ /* Store the shift. */ e[iend] = sigma; /* Store D and L. */ scopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1); i__2 = in - 1; scopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1); if (mb > 1) { /* Perturb each entry of the base representation by a small */ /* (but random) relative amount to overcome difficulties with */ /* glued matrices. */ for (i__ = 1; i__ <= 4; ++i__) { iseed[i__ - 1] = 1; /* L122: */ } i__2 = (in << 1) - 1; slarnv_(&c__2, iseed, &i__2, &work[1]); i__2 = in - 1; for (i__ = 1; i__ <= i__2; ++i__) { d__[ibegin + i__ - 1] *= eps * 4.f * work[i__] + 1.f; e[ibegin + i__ - 1] *= eps * 4.f * work[in + i__] + 1.f; /* L125: */ } d__[iend] *= eps * 4.f * work[in] + 1.f; } /* Don't update the Gerschgorin intervals because keeping track */ /* of the updates would be too much work in SLARRV. */ /* We update W instead and use it to locate the proper Gerschgorin */ /* intervals. */ /* Compute the required eigenvalues of L D L' by bisection or dqds */ if (! usedqd) { /* If SLARRD has been used, shift the eigenvalue approximations */ /* according to their representation. This is necessary for */ /* a uniform SLARRV since dqds computes eigenvalues of the */ /* shifted representation. In SLARRV, W will always hold the */ /* UNshifted eigenvalue approximation. */ i__2 = wend; for (j = wbegin; j <= i__2; ++j) { w[j] -= sigma; werr[j] += (r__1 = w[j], dabs(r__1)) * eps; /* L134: */ } /* call SLARRB to reduce eigenvalue error of the approximations */ /* from SLARRD */ i__2 = iend - 1; for (i__ = ibegin; i__ <= i__2; ++i__) { /* Computing 2nd power */ r__1 = e[i__]; work[i__] = d__[i__] * (r__1 * r__1); /* L135: */ } /* use bisection to find EV from INDL to INDU */ i__2 = indl - 1; slarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1, rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], & work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, & iinfo); if (iinfo != 0) { *info = -4; return 0; } /* SLARRB computes all gaps correctly except for the last one */ /* Record distance to VU/GU */ /* Computing MAX */ r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); wgap[wend] = dmax(r__1, r__2); i__2 = indu; for (i__ = indl; i__ <= i__2; ++i__) { ++(*m); iblock[*m] = jblk; indexw[*m] = i__; /* L138: */ } } else { /* Call dqds to get all eigs (and then possibly delete unwanted */ /* eigenvalues). */ /* Note that dqds finds the eigenvalues of the L D L^T representation */ /* of T to high relative accuracy. High relative accuracy */ /* might be lost when the shift of the RRR is subtracted to obtain */ /* the eigenvalues of T. However, T is not guaranteed to define its */ /* eigenvalues to high relative accuracy anyway. */ /* Set RTOL to the order of the tolerance used in SLASQ2 */ /* This is an ESTIMATED error, the worst case bound is 4*N*EPS */ /* which is usually too large and requires unnecessary work to be */ /* done by bisection when computing the eigenvectors */ rtol = log((real) in) * 4.f * eps; j = ibegin; i__2 = in - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[(i__ << 1) - 1] = (r__1 = d__[j], dabs(r__1)); work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1]; ++j; /* L140: */ } work[(in << 1) - 1] = (r__1 = d__[iend], dabs(r__1)); work[in * 2] = 0.f; slasq2_(&in, &work[1], &iinfo); if (iinfo != 0) { /* If IINFO = -5 then an index is part of a tight cluster */ /* and should be changed. The index is in IWORK(1) and the */ /* gap is in WORK(N+1) */ *info = -5; return 0; } else { /* Test that all eigenvalues are positive as expected */ i__2 = in; for (i__ = 1; i__ <= i__2; ++i__) { if (work[i__] < 0.f) { *info = -6; return 0; } /* L149: */ } } if (sgndef > 0.f) { i__2 = indu; for (i__ = indl; i__ <= i__2; ++i__) { ++(*m); w[*m] = work[in - i__ + 1]; iblock[*m] = jblk; indexw[*m] = i__; /* L150: */ } } else { i__2 = indu; for (i__ = indl; i__ <= i__2; ++i__) { ++(*m); w[*m] = -work[i__]; iblock[*m] = jblk; indexw[*m] = i__; /* L160: */ } } i__2 = *m; for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { /* the value of RTOL below should be the tolerance in SLASQ2 */ werr[i__] = rtol * (r__1 = w[i__], dabs(r__1)); /* L165: */ } i__2 = *m - 1; for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { /* compute the right gap between the intervals */ /* Computing MAX */ r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[i__]); wgap[i__] = dmax(r__1, r__2); /* L166: */ } /* Computing MAX */ r__1 = 0.f, r__2 = *vu - sigma - (w[*m] + werr[*m]); wgap[*m] = dmax(r__1, r__2); } /* proceed with next block */ ibegin = iend + 1; wbegin = wend + 1; L170: ; } return 0; /* end of SLARRE */ } /* slarre_ */
/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__, real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz, logical *tryrac, real *work, integer *lwork, integer *iwork, integer * liwork, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2; real r__1, r__2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; real r1, r2; integer jj; real cs; integer in; real sn, wl, wu; integer iil, iiu; real eps, tmp; integer indd, iend, jblk, wend; real rmin, rmax; integer itmp; real tnrm; integer inde2; extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) ; integer itmp2; real rtol1, rtol2, scale; integer indgp; extern logical lsame_(char *, char *); integer iinfo; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer iindw, ilast, lwmin; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); logical wantz; extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real * , real *, real *); logical alleig; integer ibegin; logical indeig; integer iindbl; logical valeig; extern doublereal slamch_(char *); integer wbegin; real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); real bignum; integer inderr, iindwk, indgrs, offset; extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *, real *, real *, real *, integer *, integer *, integer *, integer * ), slarre_(char *, integer *, real *, real *, integer *, integer *, real *, real *, real *, real *, real *, real *, integer *, integer *, integer *, real *, real *, real *, integer * , integer *, real *, real *, real *, integer *, integer *) ; real thresh; integer iinspl, indwrk, ifirst, liwmin, nzcmin; real pivmin; extern doublereal slanst_(char *, integer *, real *, real *); extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *, integer *, real *, integer *, real *, real *, real *, integer *, real *, real *, integer *), slarrr_(integer *, real *, real *, integer *); integer nsplit; extern /* Subroutine */ int slarrv_(integer *, real *, real *, real *, real *, real *, integer *, integer *, integer *, integer *, real * , real *, real *, real *, real *, real *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer * ); real smlnum; extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); logical lquery, zquery; /* -- LAPACK computational routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SSTEMR computes selected eigenvalues and, optionally, eigenvectors */ /* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ /* a well defined set of pairwise different real eigenvalues, the corresponding */ /* real eigenvectors are pairwise orthogonal. */ /* The spectrum may be computed either completely or partially by specifying */ /* either an interval (VL,VU] or a range of indices IL:IU for the desired */ /* eigenvalues. */ /* Depending on the number of desired eigenvalues, these are computed either */ /* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ /* computed by the use of various suitable L D L^T factorizations near clusters */ /* of close eigenvalues (referred to as RRRs, Relatively Robust */ /* Representations). An informal sketch of the algorithm follows. */ /* For each unreduced block (submatrix) of T, */ /* (a) Compute T - sigma I = L D L^T, so that L and D */ /* define all the wanted eigenvalues to high relative accuracy. */ /* This means that small relative changes in the entries of D and L */ /* cause only small relative changes in the eigenvalues and */ /* eigenvectors. The standard (unfactored) representation of the */ /* tridiagonal matrix T does not have this property in general. */ /* (b) Compute the eigenvalues to suitable accuracy. */ /* If the eigenvectors are desired, the algorithm attains full */ /* accuracy of the computed eigenvalues only right before */ /* the corresponding vectors have to be computed, see steps c) and d). */ /* (c) For each cluster of close eigenvalues, select a new */ /* shift close to the cluster, find a new factorization, and refine */ /* the shifted eigenvalues to suitable accuracy. */ /* (d) For each eigenvalue with a large enough relative separation compute */ /* the corresponding eigenvector by forming a rank revealing twisted */ /* factorization. Go back to (c) for any clusters that remain. */ /* For more details, see: */ /* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ /* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ /* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ /* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ /* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ /* 2004. Also LAPACK Working Note 154. */ /* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ /* tridiagonal eigenvalue/eigenvector problem", */ /* Computer Science Division Technical Report No. UCB/CSD-97-971, */ /* UC Berkeley, May 1997. */ /* Notes: */ /* 1.SSTEMR works only on machines which follow IEEE-754 */ /* floating-point standard in their handling of infinities and NaNs. */ /* This permits the use of efficient inner loops avoiding a check for */ /* zero divisors. */ /* Arguments */ /* ========= */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* RANGE (input) CHARACTER*1 */ /* = 'A': all eigenvalues will be found. */ /* = 'V': all eigenvalues in the half-open interval (VL,VU] */ /* will be found. */ /* = 'I': the IL-th through IU-th eigenvalues will be found. */ /* N (input) INTEGER */ /* The order of the matrix. N >= 0. */ /* D (input/output) REAL array, dimension (N) */ /* On entry, the N diagonal elements of the tridiagonal matrix */ /* T. On exit, D is overwritten. */ /* E (input/output) REAL array, dimension (N) */ /* On entry, the (N-1) subdiagonal elements of the tridiagonal */ /* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ /* input, but is used internally as workspace. */ /* On exit, E is overwritten. */ /* VL (input) REAL */ /* VU (input) REAL */ /* If RANGE='V', the lower and upper bounds of the interval to */ /* be searched for eigenvalues. VL < VU. */ /* Not referenced if RANGE = 'A' or 'I'. */ /* IL (input) INTEGER */ /* IU (input) INTEGER */ /* If RANGE='I', the indices (in ascending order) of the */ /* smallest and largest eigenvalues to be returned. */ /* 1 <= IL <= IU <= N, if N > 0. */ /* Not referenced if RANGE = 'A' or 'V'. */ /* M (output) INTEGER */ /* The total number of eigenvalues found. 0 <= M <= N. */ /* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ /* W (output) REAL array, dimension (N) */ /* The first M elements contain the selected eigenvalues in */ /* ascending order. */ /* Z (output) REAL array, dimension (LDZ, max(1,M) ) */ /* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ /* contain the orthonormal eigenvectors of the matrix T */ /* corresponding to the selected eigenvalues, with the i-th */ /* column of Z holding the eigenvector associated with W(i). */ /* If JOBZ = 'N', then Z is not referenced. */ /* Note: the user must ensure that at least max(1,M) columns are */ /* supplied in the array Z; if RANGE = 'V', the exact value of M */ /* is not known in advance and can be computed with a workspace */ /* query by setting NZC = -1, see below. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', then LDZ >= max(1,N). */ /* NZC (input) INTEGER */ /* The number of eigenvectors to be held in the array Z. */ /* If RANGE = 'A', then NZC >= max(1,N). */ /* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ /* If RANGE = 'I', then NZC >= IU-IL+1. */ /* If NZC = -1, then a workspace query is assumed; the */ /* routine calculates the number of columns of the array Z that */ /* are needed to hold the eigenvectors. */ /* This value is returned as the first entry of the Z array, and */ /* no error message related to NZC is issued by XERBLA. */ /* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */ /* The support of the eigenvectors in Z, i.e., the indices */ /* indicating the nonzero elements in Z. The i-th computed eigenvector */ /* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ /* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ /* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ /* TRYRAC (input/output) LOGICAL */ /* If TRYRAC.EQ..TRUE., indicates that the code should check whether */ /* the tridiagonal matrix defines its eigenvalues to high relative */ /* accuracy. If so, the code uses relative-accuracy preserving */ /* algorithms that might be (a bit) slower depending on the matrix. */ /* If the matrix does not define its eigenvalues to high relative */ /* accuracy, the code can uses possibly faster algorithms. */ /* If TRYRAC.EQ..FALSE., the code is not required to guarantee */ /* relatively accurate eigenvalues and can use the fastest possible */ /* techniques. */ /* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ /* does not define its eigenvalues to high relative accuracy. */ /* WORK (workspace/output) REAL array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal */ /* (and minimal) LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK >= max(1,18*N) */ /* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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. */ /* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */ /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ /* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ /* if only the eigenvalues are to be computed. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal size of the IWORK array, */ /* returns this value as the first entry of the IWORK array, and */ /* no error message related to LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* On exit, INFO */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = 1X, internal error in SLARRE, */ /* if INFO = 2X, internal error in SLARRV. */ /* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ /* the nonzero error code returned by SLARRE or */ /* SLARRV, respectively. */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Beresford Parlett, University of California, Berkeley, USA */ /* Jim Demmel, University of California, Berkeley, USA */ /* Inderjit Dhillon, University of Texas, Austin, USA */ /* Osni Marques, LBNL/NERSC, USA */ /* Christof Voemel, University of California, Berkeley, USA */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --d__; --e; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); alleig = lsame_(range, "A"); valeig = lsame_(range, "V"); indeig = lsame_(range, "I"); lquery = *lwork == -1 || *liwork == -1; zquery = *nzc == -1; *tryrac = *info != 0; /* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ /* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */ /* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N. */ if (wantz) { lwmin = *n * 18; liwmin = *n * 10; } else { /* need less workspace if only the eigenvalues are wanted */ lwmin = *n * 12; liwmin = *n << 3; } wl = 0.f; wu = 0.f; iil = 0; iiu = 0; if (valeig) { /* We do not reference VL, VU in the cases RANGE = 'I','A' */ /* The interval (WL, WU] contains all the wanted eigenvalues. */ /* It is either given by the user or computed in SLARRE. */ wl = *vl; wu = *vu; } else if (indeig) { /* We do not reference IL, IU in the cases RANGE = 'V','A' */ iil = *il; iiu = *iu; } *info = 0; if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (alleig || valeig || indeig)) { *info = -2; } else if (*n < 0) { *info = -3; } else if (valeig && *n > 0 && wu <= wl) { *info = -7; } else if (indeig && (iil < 1 || iil > *n)) { *info = -8; } else if (indeig && (iiu < iil || iiu > *n)) { *info = -9; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -13; } else if (*lwork < lwmin && ! lquery) { *info = -17; } else if (*liwork < liwmin && ! lquery) { *info = -19; } /* Get machine constants. */ safmin = slamch_("Safe minimum"); eps = slamch_("Precision"); smlnum = safmin / eps; bignum = 1.f / smlnum; rmin = sqrt(smlnum); /* Computing MIN */ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin)); rmax = dmin(r__1,r__2); if (*info == 0) { work[1] = (real) lwmin; iwork[1] = liwmin; if (wantz && alleig) { nzcmin = *n; } else if (wantz && valeig) { slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & itmp2, info); } else if (wantz && indeig) { nzcmin = iiu - iil + 1; } else { /* WANTZ .EQ. FALSE. */ nzcmin = 0; } if (zquery && *info == 0) { z__[z_dim1 + 1] = (real) nzcmin; } else if (*nzc < nzcmin && ! zquery) { *info = -14; } } if (*info != 0) { i__1 = -(*info); xerbla_("SSTEMR", &i__1); return 0; } else if (lquery || zquery) { return 0; } /* Handle N = 0, 1, and 2 cases immediately */ *m = 0; if (*n == 0) { return 0; } if (*n == 1) { if (alleig || indeig) { *m = 1; w[1] = d__[1]; } else { if (wl < d__[1] && wu >= d__[1]) { *m = 1; w[1] = d__[1]; } } if (wantz && ! zquery) { z__[z_dim1 + 1] = 1.f; isuppz[1] = 1; isuppz[2] = 1; } return 0; } if (*n == 2) { if (! wantz) { slae2_(&d__[1], &e[1], &d__[2], &r1, &r2); } else if (wantz && ! zquery) { slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); } if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { ++(*m); w[*m] = r2; if (wantz && ! zquery) { z__[*m * z_dim1 + 1] = -sn; z__[*m * z_dim1 + 2] = cs; /* Note: At most one of SN and CS can be zero. */ if (sn != 0.f) { if (cs != 0.f) { isuppz[(*m << 1) - 1] = 1; isuppz[(*m << 1) - 1] = 2; } else { isuppz[(*m << 1) - 1] = 1; isuppz[(*m << 1) - 1] = 1; } } else { isuppz[(*m << 1) - 1] = 2; isuppz[*m * 2] = 2; } } } if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { ++(*m); w[*m] = r1; if (wantz && ! zquery) { z__[*m * z_dim1 + 1] = cs; z__[*m * z_dim1 + 2] = sn; /* Note: At most one of SN and CS can be zero. */ if (sn != 0.f) { if (cs != 0.f) { isuppz[(*m << 1) - 1] = 1; isuppz[(*m << 1) - 1] = 2; } else { isuppz[(*m << 1) - 1] = 1; isuppz[(*m << 1) - 1] = 1; } } else { isuppz[(*m << 1) - 1] = 2; isuppz[*m * 2] = 2; } } } return 0; } /* Continue with general N */ indgrs = 1; inderr = (*n << 1) + 1; indgp = *n * 3 + 1; indd = (*n << 2) + 1; inde2 = *n * 5 + 1; indwrk = *n * 6 + 1; iinspl = 1; iindbl = *n + 1; iindw = (*n << 1) + 1; iindwk = *n * 3 + 1; /* Scale matrix to allowable range, if necessary. */ /* The allowable range is related to the PIVMIN parameter; see the */ /* comments in SLARRD. The preference for scaling small values */ /* up is heuristic; we expect users' matrices not to be close to the */ /* RMAX threshold. */ scale = 1.f; tnrm = slanst_("M", n, &d__[1], &e[1]); if (tnrm > 0.f && tnrm < rmin) { scale = rmin / tnrm; } else if (tnrm > rmax) { scale = rmax / tnrm; } if (scale != 1.f) { sscal_(n, &scale, &d__[1], &c__1); i__1 = *n - 1; sscal_(&i__1, &scale, &e[1], &c__1); tnrm *= scale; if (valeig) { /* If eigenvalues in interval have to be found, */ /* scale (WL, WU] accordingly */ wl *= scale; wu *= scale; } } /* Compute the desired eigenvalues of the tridiagonal after splitting */ /* into smaller subblocks if the corresponding off-diagonal elements */ /* are small */ /* THRESH is the splitting parameter for SLARRE */ /* A negative THRESH forces the old splitting criterion based on the */ /* size of the off-diagonal. A positive THRESH switches to splitting */ /* which preserves relative accuracy. */ if (*tryrac) { /* Test whether the matrix warrants the more expensive relative approach. */ slarrr_(n, &d__[1], &e[1], &iinfo); } else { /* The user does not care about relative accurately eigenvalues */ iinfo = -1; } /* Set the splitting criterion */ if (iinfo == 0) { thresh = eps; } else { thresh = -eps; /* relative accuracy is desired but T does not guarantee it */ *tryrac = FALSE_; } if (*tryrac) { /* Copy original diagonal, needed to guarantee relative accuracy */ scopy_(n, &d__[1], &c__1, &work[indd], &c__1); } /* Store the squares of the offdiagonal values of T */ i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing 2nd power */ r__1 = e[j]; work[inde2 + j - 1] = r__1 * r__1; /* L5: */ } /* Set the tolerance parameters for bisection */ if (! wantz) { /* SLARRE computes the eigenvalues to full precision. */ rtol1 = eps * 4.f; rtol2 = eps * 4.f; } else { /* SLARRE computes the eigenvalues to less than full precision. */ /* SLARRV will refine the eigenvalue approximations, and we can */ /* need less accurate initial bisection in SLARRE. */ /* Note: these settings do only affect the subset case and SLARRE */ /* Computing MAX */ r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f; rtol1 = dmax(r__1,r__2); /* Computing MAX */ r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f; rtol2 = dmax(r__1,r__2); } slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], & rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[ inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[ indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); if (iinfo != 0) { *info = abs(iinfo) + 10; return 0; } /* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */ /* part of the spectrum. All desired eigenvalues are contained in */ /* (WL,WU] */ if (wantz) { /* Compute the desired eigenvectors corresponding to the computed */ /* eigenvalues */ slarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[ indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[ z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], & iinfo); if (iinfo != 0) { *info = abs(iinfo) + 20; return 0; } } else { /* SLARRE computes eigenvalues of the (shifted) root representation */ /* SLARRV returns the eigenvalues of the unshifted matrix. */ /* However, if the eigenvectors are not desired by the user, we need */ /* to apply the corresponding shifts from SLARRE to obtain the */ /* eigenvalues of the original matrix. */ i__1 = *m; for (j = 1; j <= i__1; ++j) { itmp = iwork[iindbl + j - 1]; w[j] += e[iwork[iinspl + itmp - 1]]; /* L20: */ } } if (*tryrac) { /* Refine computed eigenvalues so that they are relatively accurate */ /* with respect to the original matrix T. */ ibegin = 1; wbegin = 1; i__1 = iwork[iindbl + *m - 1]; for (jblk = 1; jblk <= i__1; ++jblk) { iend = iwork[iinspl + jblk - 1]; in = iend - ibegin + 1; wend = wbegin - 1; /* check if any eigenvalues have to be refined in this block */ L36: if (wend < *m) { if (iwork[iindbl + wend] == jblk) { ++wend; goto L36; } } if (wend < wbegin) { ibegin = iend + 1; goto L39; } offset = iwork[iindw + wbegin - 1] - 1; ifirst = iwork[iindw + wbegin - 1]; ilast = iwork[iindw + wend - 1]; rtol2 = eps * 4.f; slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[ inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], & pivmin, &tnrm, &iinfo); ibegin = iend + 1; wbegin = wend + 1; L39: ; } } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (scale != 1.f) { r__1 = 1.f / scale; sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in increasing order, then sort them, */ /* possibly along with eigenvectors. */ if (nsplit > 1) { if (! wantz) { slasrt_("I", m, &w[1], &iinfo); if (iinfo != 0) { *info = 3; return 0; } } else { i__1 = *m - 1; for (j = 1; j <= i__1; ++j) { i__ = 0; tmp = w[j]; i__2 = *m; for (jj = j + 1; jj <= i__2; ++jj) { if (w[jj] < tmp) { i__ = jj; tmp = w[jj]; } /* L50: */ } if (i__ != 0) { w[i__] = w[j]; w[j] = tmp; if (wantz) { sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); itmp = isuppz[(i__ << 1) - 1]; isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; isuppz[(j << 1) - 1] = itmp; itmp = isuppz[i__ * 2]; isuppz[i__ * 2] = isuppz[j * 2]; isuppz[j * 2] = itmp; } } /* L60: */ } } } work[1] = (real) lwmin; iwork[1] = liwmin; return 0; /* End of SSTEMR */ } /* sstemr_ */