slaneg.f

          FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )
          IMPLICIT NONE
          INTEGER SLANEG
    *
    *  -- LAPACK auxiliary routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          INTEGER            N, R
          REAL               PIVMIN, SIGMA
    *     ..
    *     .. Array Arguments ..
          REAL               D( * ), LLD( * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  SLANEG computes the Sturm count, the number of negative pivots
    *  encountered while factoring tridiagonal T - sigma I = L D L^T.
    *  This implementation works directly on the factors without forming
    *  the tridiagonal matrix T.  The Sturm count is also the number of
    *  eigenvalues of T less than sigma.
    *
    *  This routine is called from SLARRB.
    *
    *  The current routine does not use the PIVMIN parameter but rather
    *  requires IEEE-754 propagation of Infinities and NaNs.  This
    *  routine also has no input range restrictions but does require
    *  default exception handling such that x/0 produces Inf when x is
    *  non-zero, and Inf/Inf produces NaN.  For more information, see:
    *
    *    Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
    *    Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
    *    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624
    *    (Tech report version in LAWN 172 with the same title.)
    *
    *  Arguments
    *  =========
    *
    *  N       (input) INTEGER
    *          The order of the matrix.
    *
    *  D       (input) REAL             array, dimension (N)
    *          The N diagonal elements of the diagonal matrix D.
    *
    *  LLD     (input) REAL             array, dimension (N-1)
    *          The (N-1) elements L(i)*L(i)*D(i).
    *
    *  SIGMA   (input) REAL
    *          Shift amount in T - sigma I = L D L^T.
    *
    *  PIVMIN  (input) REAL
    *          The minimum pivot in the Sturm sequence.  May be used
    *          when zero pivots are encountered on non-IEEE-754
    *          architectures.
    *
    *  R       (input) INTEGER
    *          The twist index for the twisted factorization that is used
    *          for the negcount.
    *
    *  Further Details
    *  ===============
    *
    *  Based on contributions by
    *     Osni Marques, LBNL/NERSC, USA
    *     Christof Voemel, University of California, Berkeley, USA
    *     Jason Riedy, University of California, Berkeley, USA
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          REAL               ZERO, ONE
          PARAMETER        ( ZERO = 0.0E0, ONE = 1.0E0 )
    *     Some architectures propagate Infinities and NaNs very slowly, so
    *     the code computes counts in BLKLEN chunks.  Then a NaN can
    *     propagate at most BLKLEN columns before being detected.  This is
    *     not a general tuning parameter; it needs only to be just large
    *     enough that the overhead is tiny in common cases.
          INTEGER BLKLEN
          PARAMETER ( BLKLEN = 128 )
    *     ..
    *     .. Local Scalars ..
          INTEGER            BJ, J, NEG1, NEG2, NEGCNT
          REAL               BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
          LOGICAL SAWNAN
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC MIN, MAX
    *     ..
    *     .. External Functions ..
          LOGICAL SISNAN
          EXTERNAL SISNAN
    *     ..
    *     .. Executable Statements ..

          NEGCNT = 0

    *     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
          T = -SIGMA
          DO 210 BJ = 1, R-1, BLKLEN
             NEG1 = 0
             BSAV = T
             DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
                DPLUS = D( J ) + T
                IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
                TMP = T / DPLUS
                T = TMP * LLD( J ) - SIGMA
     21      CONTINUE
             SAWNAN = SISNAN( T )
    *     Run a slower version of the above loop if a NaN is detected.
    *     A NaN should occur only with a zero pivot after an infinite
    *     pivot.  In that case, substituting 1 for T/DPLUS is the
    *     correct limit.
             IF( SAWNAN ) THEN
                NEG1 = 0
                T = BSAV
                DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
                   DPLUS = D( J ) + T
                   IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
                   TMP = T / DPLUS
                   IF (SISNAN(TMP)) TMP = ONE
                   T = TMP * LLD(J) - SIGMA
     22         CONTINUE
             END IF
             NEGCNT = NEGCNT + NEG1
     210  CONTINUE
    *
    *     II) lower part: L D L^T - SIGMA I = U- D- U-^T
          P = D( N ) - SIGMA
          DO 230 BJ = N-1, R, -BLKLEN
             NEG2 = 0
             BSAV = P
             DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
                DMINUS = LLD( J ) + P
                IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
                TMP = P / DMINUS
                P = TMP * D( J ) - SIGMA
     23      CONTINUE
             SAWNAN = SISNAN( P )
    *     As above, run a slower version that substitutes 1 for Inf/Inf.
    *
             IF( SAWNAN ) THEN
                NEG2 = 0
                P = BSAV
                DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
                   DMINUS = LLD( J ) + P
                   IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
                   TMP = P / DMINUS
                   IF (SISNAN(TMP)) TMP = ONE
                   P = TMP * D(J) - SIGMA
     24         CONTINUE
             END IF
             NEGCNT = NEGCNT + NEG2
     230  CONTINUE
    *
    *     III) Twist index
    *       T was shifted by SIGMA initially.
          GAMMA = (T + SIGMA) + P
          IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1

          SLANEG = NEGCNT
          END