dlasq5.f

Go to the documentation of this file.

      SUBROUTINE dlasq5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
     $                   DNM1, DNM2, IEEE )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     May 17, 2000
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            I0, N0, PP
      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
*     ..
*
*  Purpose
*  =======
*
*  DLASQ5 computes one dqds transform in ping-pong form, one
*  version for IEEE machines another for non IEEE machines.
*
*  Arguments
*  =========
*
*  I0    (input) INTEGER
*        First index.
*
*  N0    (input) INTEGER
*        Last index.
*
*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
*        an extra argument.
*
*  PP    (input) INTEGER
*        PP=0 for ping, PP=1 for pong.
*
*  TAU   (input) DOUBLE PRECISION
*        This is the shift.
*
*  DMIN  (output) DOUBLE PRECISION
*        Minimum value of d.
*
*  DMIN1 (output) DOUBLE PRECISION
*        Minimum value of d, excluding D( N0 ).
*
*  DMIN2 (output) DOUBLE PRECISION
*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*
*  DN    (output) DOUBLE PRECISION
*        d(N0), the last value of d.
*
*  DNM1  (output) DOUBLE PRECISION
*        d(N0-1).
*
*  DNM2  (output) DOUBLE PRECISION
*        d(N0-2).
*
*  IEEE  (input) LOGICAL
*        Flag for IEEE or non IEEE arithmetic.
*
*  =====================================================================
*
*     .. Parameter ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J4, J4P2
      DOUBLE PRECISION   D, EMIN, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( ( n0-i0-1 ).LE.0 )
     $   RETURN
*
      j4 = 4*i0 + pp - 3
      emin = z( j4+4 )
      d = z( j4 ) - tau
      dmin = d
      dmin1 = -z( j4 )
*
      IF( ieee ) THEN
*
*        Code for IEEE arithmetic.
*
         IF( pp.EQ.0 ) THEN
            DO 10 j4 = 4*i0, 4*( n0-3 ), 4
               z( j4-2 ) = d + z( j4-1 )
               temp = z( j4+1 ) / z( j4-2 )
               d = d*temp - tau
               dmin = min( dmin, d )
               z( j4 ) = z( j4-1 )*temp
               emin = min( z( j4 ), emin )
   10       CONTINUE
         ELSE
            DO 20 j4 = 4*i0, 4*( n0-3 ), 4
               z( j4-3 ) = d + z( j4 )
               temp = z( j4+2 ) / z( j4-3 )
               d = d*temp - tau
               dmin = min( dmin, d )
               z( j4-1 ) = z( j4 )*temp
               emin = min( z( j4-1 ), emin )
   20       CONTINUE
         END IF
*
*        Unroll last two steps.
*
         dnm2 = d
         dmin2 = dmin
         j4 = 4*( n0-2 ) - pp
         j4p2 = j4 + 2*pp - 1
         z( j4-2 ) = dnm2 + z( j4p2 )
         z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
         dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
         dmin = min( dmin, dnm1 )
*
         dmin1 = dmin
         j4 = j4 + 4
         j4p2 = j4 + 2*pp - 1
         z( j4-2 ) = dnm1 + z( j4p2 )
         z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
         dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
         dmin = min( dmin, dn )
*
      ELSE
*
*        Code for non IEEE arithmetic.
*
         IF( pp.EQ.0 ) THEN
            DO 30 j4 = 4*i0, 4*( n0-3 ), 4
               z( j4-2 ) = d + z( j4-1 )
               IF( d.LT.zero ) THEN
                  RETURN
               ELSE
                  z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
                  d = z( j4+1 )*( d / z( j4-2 ) ) - tau
               END IF
               dmin = min( dmin, d )
               emin = min( emin, z( j4 ) )
   30       CONTINUE
         ELSE
            DO 40 j4 = 4*i0, 4*( n0-3 ), 4
               z( j4-3 ) = d + z( j4 )
               IF( d.LT.zero ) THEN
                  RETURN
               ELSE
                  z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
                  d = z( j4+2 )*( d / z( j4-3 ) ) - tau
               END IF
               dmin = min( dmin, d )
               emin = min( emin, z( j4-1 ) )
   40       CONTINUE
         END IF
*
*        Unroll last two steps.
*
         dnm2 = d
         dmin2 = dmin
         j4 = 4*( n0-2 ) - pp
         j4p2 = j4 + 2*pp - 1
         z( j4-2 ) = dnm2 + z( j4p2 )
         IF( dnm2.LT.zero ) THEN
            RETURN
         ELSE
            z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
            dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
         END IF
         dmin = min( dmin, dnm1 )
*
         dmin1 = dmin
         j4 = j4 + 4
         j4p2 = j4 + 2*pp - 1
         z( j4-2 ) = dnm1 + z( j4p2 )
         IF( dnm1.LT.zero ) THEN
            RETURN
         ELSE
            z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
            dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
         END IF
         dmin = min( dmin, dn )
*
      END IF
*
      z( j4+2 ) = dn
      z( 4*n0-pp ) = emin
      RETURN
*
*     End of DLASQ5
*
      END