slarrf.f

Go to the documentation of this file.

*> \brief \b SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> Download SLARRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarrf.f">
*> [TXT]</a>
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
*                          W, WGAP, WERR,
*                          SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
*                          DPLUS, LPLUS, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            CLSTRT, CLEND, INFO, N
*       REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
*      $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Given the initial representation L D L^T and its cluster of close
*> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
*> W( CLEND ), SLARRF finds a new relatively robust representation
*> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
*> eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix (subblock, if the matrix split).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The N diagonal elements of the diagonal matrix D.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*>          L is REAL array, dimension (N-1)
*>          The (N-1) subdiagonal elements of the unit bidiagonal
*>          matrix L.
*> \endverbatim
*>
*> \param[in] LD
*> \verbatim
*>          LD is REAL array, dimension (N-1)
*>          The (N-1) elements L(i)*D(i).
*> \endverbatim
*>
*> \param[in] CLSTRT
*> \verbatim
*>          CLSTRT is INTEGER
*>          The index of the first eigenvalue in the cluster.
*> \endverbatim
*>
*> \param[in] CLEND
*> \verbatim
*>          CLEND is INTEGER
*>          The index of the last eigenvalue in the cluster.
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*>          W is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
*>          W( CLSTRT ) through W( CLEND ) form the cluster of relatively
*>          close eigenalues.
*> \endverbatim
*>
*> \param[in,out] WGAP
*> \verbatim
*>          WGAP is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          The separation from the right neighbor eigenvalue in W.
*> \endverbatim
*>
*> \param[in] WERR
*> \verbatim
*>          WERR is REAL array, dimension
*>          dimension is >=  (CLEND-CLSTRT+1)
*>          WERR contain the semiwidth of the uncertainty
*>          interval of the corresponding eigenvalue APPROXIMATION in W
*> \endverbatim
*>
*> \param[in] SPDIAM
*> \verbatim
*>          SPDIAM is REAL
*>          estimate of the spectral diameter obtained from the
*>          Gerschgorin intervals
*> \endverbatim
*>
*> \param[in] CLGAPL
*> \verbatim
*>          CLGAPL is REAL
*> \endverbatim
*>
*> \param[in] CLGAPR
*> \verbatim
*>          CLGAPR is REAL
*>          absolute gap on each end of the cluster.
*>          Set by the calling routine to protect against shifts too close
*>          to eigenvalues outside the cluster.
*> \endverbatim
*>
*> \param[in] PIVMIN
*> \verbatim
*>          PIVMIN is REAL
*>          The minimum pivot allowed in the Sturm sequence.
*> \endverbatim
*>
*> \param[out] SIGMA
*> \verbatim
*>          SIGMA is REAL
*>          The shift used to form L(+) D(+) L(+)^T.
*> \endverbatim
*>
*> \param[out] DPLUS
*> \verbatim
*>          DPLUS is REAL array, dimension (N)
*>          The N diagonal elements of the diagonal matrix D(+).
*> \endverbatim
*>
*> \param[out] LPLUS
*> \verbatim
*>          LPLUS is REAL array, dimension (N-1)
*>          The first (N-1) elements of LPLUS contain the subdiagonal
*>          elements of the unit bidiagonal matrix L(+).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (2*N)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          Signals processing OK (=0) or failure (=1)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larrf
*
*> \par Contributors:
*  ==================
*>
*> Beresford Parlett, University of California, Berkeley, USA \n
*> Jim Demmel, University of California, Berkeley, USA \n
*> Inderjit Dhillon, University of Texas, Austin, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*> Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
      SUBROUTINE slarrf( N, D, L, LD, CLSTRT, CLEND,
     $                   W, WGAP, WERR,
     $                   SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
     $                   DPLUS, LPLUS, WORK, INFO )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            CLSTRT, CLEND, INFO, N
      REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*     ..
*     .. Array Arguments ..
      REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
      PARAMETER          ( ONE = 1.0e0, two = 2.0e0,
     $                     quart = 0.25e0,
     $                     maxgrowth1 = 8.e0,
     $                     maxgrowth2 = 8.e0 )
*     ..
*     .. Local Scalars ..
      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
      PARAMETER          ( KTRYMAX = 1, sleft = 1, sright = 2 )
      REAL               AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
     $                   fail2, growthbound, ldelta, ldmax, lsigma,
     $                   max1, max2, mingap, oldp, prod, rdelta, rdmax,
     $                   rrr1, rrr2, rsigma, s, smlgrowth, tmp, znm2
*     ..
*     .. External Functions ..
      LOGICAL SISNAN
      REAL               SLAMCH
      EXTERNAL           SISNAN, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      fact = real(2**ktrymax)
      eps = slamch( 'Precision' )
      shift = 0
      forcer = .false.
 
 
*     Note that we cannot guarantee that for any of the shifts tried,
*     the factorization has a small or even moderate element growth.
*     There could be Ritz values at both ends of the cluster and despite
*     backing off, there are examples where all factorizations tried
*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
*     element growth.
*     For this reason, we should use PIVMIN in this subroutine so that at
*     least the L D L^T factorization exists. It can be checked afterwards
*     whether the element growth caused bad residuals/orthogonality.
 
*     Decide whether the code should accept the best among all
*     representations despite large element growth or signal INFO=1
*     Setting NOFAIL to .FALSE. for quick fix for bug 113
      nofail = .false.
*
 
*     Compute the average gap length of the cluster
      clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt)
      avgap = clwdth / real(clend-clstrt)
      mingap = min(clgapl, clgapr)
*     Initial values for shifts to both ends of cluster
      lsigma = min(w( clstrt ),w( clend )) - werr( clstrt )
      rsigma = max(w( clstrt ),w( clend )) + werr( clend )
 
*     Use a small fudge to make sure that we really shift to the outside
      lsigma = lsigma - abs(lsigma)* two * eps
      rsigma = rsigma + abs(rsigma)* two * eps
 
*     Compute upper bounds for how much to back off the initial shifts
      ldmax = quart * mingap + two * pivmin
      rdmax = quart * mingap + two * pivmin
 
      ldelta = max(avgap,wgap( clstrt ))/fact
      rdelta = max(avgap,wgap( clend-1 ))/fact
*
*     Initialize the record of the best representation found
*
      s = slamch( 'S' )
      smlgrowth = one / s
      fail = real(n-1)*mingap/(spdiam*eps)
      fail2 = real(n-1)*mingap/(spdiam*sqrt(eps))
      bestshift = lsigma
*
*     while (KTRY <= KTRYMAX)
      ktry = 0
      growthbound = maxgrowth1*spdiam
 
 5    CONTINUE
      sawnan1 = .false.
      sawnan2 = .false.
*     Ensure that we do not back off too much of the initial shifts
      ldelta = min(ldmax,ldelta)
      rdelta = min(rdmax,rdelta)
 
*     Compute the element growth when shifting to both ends of the cluster
*     accept the shift if there is no element growth at one of the two ends
 
*     Left end
      s = -lsigma
      dplus( 1 ) = d( 1 ) + s
      IF(abs(dplus(1)).LT.pivmin) THEN
         dplus(1) = -pivmin
*        Need to set SAWNAN1 because refined RRR test should not be used
*        in this case
         sawnan1 = .true.
      ENDIF
      max1 = abs( dplus( 1 ) )
      DO 6 i = 1, n - 1
         lplus( i ) = ld( i ) / dplus( i )
         s = s*lplus( i )*l( i ) - lsigma
         dplus( i+1 ) = d( i+1 ) + s
         IF(abs(dplus(i+1)).LT.pivmin) THEN
            dplus(i+1) = -pivmin
*           Need to set SAWNAN1 because refined RRR test should not be used
*           in this case
            sawnan1 = .true.
         ENDIF
         max1 = max( max1,abs(dplus(i+1)) )
 6    CONTINUE
      sawnan1 = sawnan1 .OR.  sisnan( max1 )
 
      IF( forcer .OR.
     $   (max1.LE.growthbound .AND. .NOT.sawnan1 ) ) THEN
         sigma = lsigma
         shift = sleft
         GOTO 100
      ENDIF
 
*     Right end
      s = -rsigma
      work( 1 ) = d( 1 ) + s
      IF(abs(work(1)).LT.pivmin) THEN
         work(1) = -pivmin
*        Need to set SAWNAN2 because refined RRR test should not be used
*        in this case
         sawnan2 = .true.
      ENDIF
      max2 = abs( work( 1 ) )
      DO 7 i = 1, n - 1
         work( n+i ) = ld( i ) / work( i )
         s = s*work( n+i )*l( i ) - rsigma
         work( i+1 ) = d( i+1 ) + s
         IF(abs(work(i+1)).LT.pivmin) THEN
            work(i+1) = -pivmin
*           Need to set SAWNAN2 because refined RRR test should not be used
*           in this case
            sawnan2 = .true.
         ENDIF
         max2 = max( max2,abs(work(i+1)) )
 7    CONTINUE
      sawnan2 = sawnan2 .OR.  sisnan( max2 )
 
      IF( forcer .OR.
     $   (max2.LE.growthbound .AND. .NOT.sawnan2 ) ) THEN
         sigma = rsigma
         shift = sright
         GOTO 100
      ENDIF
*     If we are at this point, both shifts led to too much element growth
 
*     Record the better of the two shifts (provided it didn't lead to NaN)
      IF(sawnan1.AND.sawnan2) THEN
*        both MAX1 and MAX2 are NaN
         GOTO 50
      ELSE
         IF( .NOT.sawnan1 ) THEN
            indx = 1
            IF(max1.LE.smlgrowth) THEN
               smlgrowth = max1
               bestshift = lsigma
            ENDIF
         ENDIF
         IF( .NOT.sawnan2 ) THEN
            IF(sawnan1 .OR. max2.LE.max1) indx = 2
            IF(max2.LE.smlgrowth) THEN
               smlgrowth = max2
               bestshift = rsigma
            ENDIF
         ENDIF
      ENDIF
 
*     If we are here, both the left and the right shift led to
*     element growth. If the element growth is moderate, then
*     we may still accept the representation, if it passes a
*     refined test for RRR. This test supposes that no NaN occurred.
*     Moreover, we use the refined RRR test only for isolated clusters.
      IF((clwdth.LT.mingap/real(128)) .AND.
     $   (min(max1,max2).LT.fail2)
     $  .AND.(.NOT.sawnan1).AND.(.NOT.sawnan2)) THEN
         dorrr1 = .true.
      ELSE
         dorrr1 = .false.
      ENDIF
      tryrrr1 = .true.
      IF( tryrrr1 .AND. dorrr1 ) THEN
      IF(indx.EQ.1) THEN
         tmp = abs( dplus( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 15 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod =
     $         ((dplus(i+1)*work(n+i+1))/(dplus(i)*work(n+i)))*oldp
            ELSE
               prod = prod*abs(work(n+i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( dplus( i ) * prod ))
 15      CONTINUE
         rrr1 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr1.LE.maxgrowth2) THEN
            sigma = lsigma
            shift = sleft
            GOTO 100
         ENDIF
      ELSE IF(indx.EQ.2) THEN
         tmp = abs( work( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 16 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod = ((work(i+1)*lplus(i+1))/(work(i)*lplus(i)))*oldp
            ELSE
               prod = prod*abs(lplus(i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( work( i ) * prod ))
 16      CONTINUE
         rrr2 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr2.LE.maxgrowth2) THEN
            sigma = rsigma
            shift = sright
            GOTO 100
         ENDIF
      END IF
      ENDIF
 
 50   CONTINUE
 
      IF (ktry.LT.ktrymax) THEN
*        If we are here, both shifts failed also the RRR test.
*        Back off to the outside
         lsigma = max( lsigma - ldelta,
     $     lsigma - ldmax)
         rsigma = min( rsigma + rdelta,
     $     rsigma + rdmax )
         ldelta = two * ldelta
         rdelta = two * rdelta
         ktry = ktry + 1
         GOTO 5
      ELSE
*        None of the representations investigated satisfied our
*        criteria. Take the best one we found.
         IF((smlgrowth.LT.fail).OR.nofail) THEN
            lsigma = bestshift
            rsigma = bestshift
            forcer = .true.
            GOTO 5
         ELSE
            info = 1
            RETURN
         ENDIF
      END IF
 
 100  CONTINUE
      IF (shift.EQ.sleft) THEN
      ELSEIF (shift.EQ.sright) THEN
*        store new L and D back into DPLUS, LPLUS
         CALL scopy( n, work, 1, dplus, 1 )
         CALL scopy( n-1, work(n+1), 1, lplus, 1 )
      ENDIF
 
      RETURN
*
*     End of SLARRF
*
      END