dlasq5.f

Go to the documentation of this file.

*> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at 
*            http://www.netlib.org/lapack/explore-html/ 
*
*> \htmlonly
*> Download DLASQ5 + dependencies 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq5.f"> 
*> [TGZ]</a> 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq5.f"> 
*> [ZIP]</a> 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq5.f"> 
*> [TXT]</a>
*> \endhtmlonly 
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN,
*                          DNM1, DNM2, IEEE, EPS )
* 
*       .. Scalar Arguments ..
*       LOGICAL            IEEE
*       INTEGER            I0, N0, PP
*       DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   Z( * )
*       ..
*  
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLASQ5 computes one dqds transform in ping-pong form, one
*> version for IEEE machines another for non IEEE machines.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] I0
*> \verbatim
*>          I0 is INTEGER
*>        First index.
*> \endverbatim
*>
*> \param[in] N0
*> \verbatim
*>          N0 is INTEGER
*>        Last index.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*>          Z is DOUBLE PRECISION array, dimension ( 4*N )
*>        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
*>        an extra argument.
*> \endverbatim
*>
*> \param[in] PP
*> \verbatim
*>          PP is INTEGER
*>        PP=0 for ping, PP=1 for pong.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is DOUBLE PRECISION
*>        This is the shift.
*> \endverbatim
*>
*> \param[in] SIGMA
*> \verbatim
*>          SIGMA is DOUBLE PRECISION
*>        This is the accumulated shift up to this step.
*> \endverbatim
*>
*> \param[out] DMIN
*> \verbatim
*>          DMIN is DOUBLE PRECISION
*>        Minimum value of d.
*> \endverbatim
*>
*> \param[out] DMIN1
*> \verbatim
*>          DMIN1 is DOUBLE PRECISION
*>        Minimum value of d, excluding D( N0 ).
*> \endverbatim
*>
*> \param[out] DMIN2
*> \verbatim
*>          DMIN2 is DOUBLE PRECISION
*>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*> \endverbatim
*>
*> \param[out] DN
*> \verbatim
*>          DN is DOUBLE PRECISION
*>        d(N0), the last value of d.
*> \endverbatim
*>
*> \param[out] DNM1
*> \verbatim
*>          DNM1 is DOUBLE PRECISION
*>        d(N0-1).
*> \endverbatim
*>
*> \param[out] DNM2
*> \verbatim
*>          DNM2 is DOUBLE PRECISION
*>        d(N0-2).
*> \endverbatim
*>
*> \param[in] IEEE
*> \verbatim
*>          IEEE is LOGICAL
*>        Flag for IEEE or non IEEE arithmetic.
*> \endverbatim
*
*> \param[in] EPS
*> \verbatim
*>          EPS is DOUBLE PRECISION
*>        This is the value of epsilon used.
*> \endverbatim
*>
*  Authors:
*  ========
*
*> \author Univ. of Tennessee 
*> \author Univ. of California Berkeley 
*> \author Univ. of Colorado Denver 
*> \author NAG Ltd. 
*
*> \date September 2012
*
*> \ingroup auxOTHERcomputational
*
*  =====================================================================
      SUBROUTINE dlasq5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2,
     $                   dn, dnm1, dnm2, ieee, eps )
*
*  -- LAPACK computational 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 ..
      LOGICAL            ieee
      INTEGER            i0, n0, pp
      DOUBLE PRECISION   dmin, dmin1, dmin2, dn, dnm1, dnm2, tau,
     $                   sigma, eps
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameter ..
      DOUBLE PRECISION   zero, half
      parameter( zero = 0.0d0, half = 0.5 )
*     ..
*     .. Local Scalars ..
      INTEGER            j4, j4p2
      DOUBLE PRECISION   d, emin, temp, dthresh
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( ( n0-i0-1 ).LE.0 )
     $   return
*
      dthresh = eps*(sigma+tau)
      IF( tau.LT.dthresh*half ) tau = zero
      IF( tau.NE.zero ) THEN
      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
      ELSE
*     This is the version that sets d's to zero if they are small enough
         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 50 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
                  IF( d.LT.dthresh ) d = zero
                  dmin = min( dmin, d )
                  z( j4 ) = z( j4-1 )*temp
                  emin = min( z( j4 ), emin )
 50            continue
            ELSE
               DO 60 j4 = 4*i0, 4*( n0-3 ), 4
                  z( j4-3 ) = d + z( j4 ) 
                  temp = z( j4+2 ) / z( j4-3 )
                  d = d*temp - tau
                  IF( d.LT.dthresh ) d = zero
                  dmin = min( dmin, d )
                  z( j4-1 ) = z( j4 )*temp
                  emin = min( z( j4-1 ), emin )
 60            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 70 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
                  IF( d.LT.dthresh) d = zero
                  dmin = min( dmin, d )
                  emin = min( emin, z( j4 ) )
 70            continue
            ELSE
               DO 80 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
                  IF( d.LT.dthresh) d = zero
                  dmin = min( dmin, d )
                  emin = min( emin, z( j4-1 ) )
 80            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
      END IF
*     
      z( j4+2 ) = dn
      z( 4*n0-pp ) = emin
      return
*
*     End of DLASQ5
*
      END