dlasq1.f

Go to the documentation of this file.

      SUBROUTINE dlasq1( N, D, E, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1999 
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLASQ1 computes the singular values of a real N-by-N bidiagonal
*  matrix with diagonal D and off-diagonal E. The singular values
*  are computed to high relative accuracy, in the absence of
*  denormalization, underflow and overflow. The algorithm was first
*  presented in
*
*  "Accurate singular values and differential qd algorithms" by K. V.
*  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
*  1994,
*
*  and the present implementation is described in "An implementation of
*  the dqds Algorithm (Positive Case)", LAPACK Working Note.
*
*  Arguments
*  =========
*
*  N     (input) INTEGER
*        The number of rows and columns in the matrix. N >= 0.
*
*  D     (input/output) DOUBLE PRECISION array, dimension (N)
*        On entry, D contains the diagonal elements of the
*        bidiagonal matrix whose SVD is desired. On normal exit,
*        D contains the singular values in decreasing order.
*
*  E     (input/output) DOUBLE PRECISION array, dimension (N)
*        On entry, elements E(1:N-1) contain the off-diagonal elements
*        of the bidiagonal matrix whose SVD is desired.
*        On exit, E is overwritten.
*
*  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)
*
*  INFO  (output) INTEGER
*        = 0: successful exit
*        < 0: if INFO = -i, the i-th argument had an illegal value
*        > 0: the algorithm failed
*             = 1, a split was marked by a positive value in E
*             = 2, current block of Z not diagonalized after 30*N
*                  iterations (in inner while loop)
*             = 3, termination criterion of outer while loop not met 
*                  (program created more than N unreduced blocks)
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO
      DOUBLE PRECISION   EPS, SCALE, SAFMIN, SIGMN, SIGMX
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlas2, dlasq2, dlasrt, xerbla
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sqrt
*     ..
*     .. Executable Statements ..
*
      info = 0
      IF( n.LT.0 ) THEN
         info = -2
         CALL xerbla( 'DLASQ1', -info )
         RETURN
      ELSE IF( n.EQ.0 ) THEN
         RETURN
      ELSE IF( n.EQ.1 ) THEN
         d( 1 ) = abs( d( 1 ) )
         RETURN
      ELSE IF( n.EQ.2 ) THEN
         CALL dlas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx )
         d( 1 ) = sigmx
         d( 2 ) = sigmn
         RETURN
      END IF
*
*     Estimate the largest singular value.
*
      sigmx = zero
      DO 10 i = 1, n - 1
         d( i ) = abs( d( i ) )
         sigmx = max( sigmx, abs( e( i ) ) )
   10 CONTINUE
      d( n ) = abs( d( n ) )
*
*     Early return if SIGMX is zero (matrix is already diagonal).
*
      IF( sigmx.EQ.zero ) THEN
         CALL dlasrt( 'D', n, d, iinfo )
         RETURN
      END IF
*
      DO 20 i = 1, n
         sigmx = max( sigmx, d( i ) )
   20 CONTINUE
*
*     Copy D and E into WORK (in the Z format) and scale (squaring the
*     input data makes scaling by a power of the radix pointless).
*
      eps = dlamch( 'Precision' )
      safmin = dlamch( 'Safe minimum' )
      scale = sqrt( eps / safmin )
      CALL dcopy( n, d, 1, work( 1 ), 2 )
      CALL dcopy( n-1, e, 1, work( 2 ), 2 )
      CALL dlascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,
     $             iinfo )
*         
*     Compute the q's and e's.
*
      DO 30 i = 1, 2*n - 1
         work( i ) = work( i )**2
   30 CONTINUE
      work( 2*n ) = zero
*
      CALL dlasq2( n, work, info )
*
      IF( info.EQ.0 ) THEN
         DO 40 i = 1, n
            d( i ) = sqrt( work( i ) )
   40    CONTINUE
         CALL dlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo )
      END IF
*
      RETURN
*
*     End of DLASQ1
*
      END