slasdq.f

Go to the documentation of this file.

*> \brief \b SLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at 
*            http://www.netlib.org/lapack/explore-html/ 
*
*> \htmlonly
*> Download SLASDQ + dependencies 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasdq.f"> 
*> [TGZ]</a> 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasdq.f"> 
*> [ZIP]</a> 
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasdq.f"> 
*> [TXT]</a>
*> \endhtmlonly 
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
*                          U, LDU, C, LDC, WORK, INFO )
* 
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
*       ..
*       .. Array Arguments ..
*       REAL               C( LDC, * ), D( * ), E( * ), U( LDU, * ),
*      $                   VT( LDVT, * ), WORK( * )
*       ..
*  
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLASDQ computes the singular value decomposition (SVD) of a real
*> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
*> E, accumulating the transformations if desired. Letting B denote
*> the input bidiagonal matrix, the algorithm computes orthogonal
*> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose
*> of P). The singular values S are overwritten on D.
*>
*> The input matrix U  is changed to U  * Q  if desired.
*> The input matrix VT is changed to P**T * VT if desired.
*> The input matrix C  is changed to Q**T * C  if desired.
*>
*> See "Computing  Small Singular Values of Bidiagonal Matrices With
*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
*> LAPACK Working Note #3, for a detailed description of the algorithm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>        On entry, UPLO specifies whether the input bidiagonal matrix
*>        is upper or lower bidiagonal, and whether it is square are
*>        not.
*>           UPLO = 'U' or 'u'   B is upper bidiagonal.
*>           UPLO = 'L' or 'l'   B is lower bidiagonal.
*> \endverbatim
*>
*> \param[in] SQRE
*> \verbatim
*>          SQRE is INTEGER
*>        = 0: then the input matrix is N-by-N.
*>        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
*>             (N+1)-by-N if UPLU = 'L'.
*>
*>        The bidiagonal matrix has
*>        N = NL + NR + 1 rows and
*>        M = N + SQRE >= N columns.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>        On entry, N specifies the number of rows and columns
*>        in the matrix. N must be at least 0.
*> \endverbatim
*>
*> \param[in] NCVT
*> \verbatim
*>          NCVT is INTEGER
*>        On entry, NCVT specifies the number of columns of
*>        the matrix VT. NCVT must be at least 0.
*> \endverbatim
*>
*> \param[in] NRU
*> \verbatim
*>          NRU is INTEGER
*>        On entry, NRU specifies the number of rows of
*>        the matrix U. NRU must be at least 0.
*> \endverbatim
*>
*> \param[in] NCC
*> \verbatim
*>          NCC is INTEGER
*>        On entry, NCC specifies the number of columns of
*>        the matrix C. NCC must be at least 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>        On entry, D contains the diagonal entries of the
*>        bidiagonal matrix whose SVD is desired. On normal exit,
*>        D contains the singular values in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is REAL array.
*>        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
*>        On entry, the entries of E contain the offdiagonal entries
*>        of the bidiagonal matrix whose SVD is desired. On normal
*>        exit, E will contain 0. If the algorithm does not converge,
*>        D and E will contain the diagonal and superdiagonal entries
*>        of a bidiagonal matrix orthogonally equivalent to the one
*>        given as input.
*> \endverbatim
*>
*> \param[in,out] VT
*> \verbatim
*>          VT is REAL array, dimension (LDVT, NCVT)
*>        On entry, contains a matrix which on exit has been
*>        premultiplied by P**T, dimension N-by-NCVT if SQRE = 0
*>        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>        On entry, LDVT specifies the leading dimension of VT as
*>        declared in the calling (sub) program. LDVT must be at
*>        least 1. If NCVT is nonzero LDVT must also be at least N.
*> \endverbatim
*>
*> \param[in,out] U
*> \verbatim
*>          U is REAL array, dimension (LDU, N)
*>        On entry, contains a  matrix which on exit has been
*>        postmultiplied by Q, dimension NRU-by-N if SQRE = 0
*>        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>        On entry, LDU  specifies the leading dimension of U as
*>        declared in the calling (sub) program. LDU must be at
*>        least max( 1, NRU ) .
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is REAL array, dimension (LDC, NCC)
*>        On entry, contains an N-by-NCC matrix which on exit
*>        has been premultiplied by Q**T  dimension N-by-NCC if SQRE = 0
*>        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>        On entry, LDC  specifies the leading dimension of C as
*>        declared in the calling (sub) program. LDC must be at
*>        least 1. If NCC is nonzero, LDC must also be at least N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (4*N)
*>        Workspace. Only referenced if one of NCVT, NRU, or NCC is
*>        nonzero, and if N is at least 2.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>        On exit, a value of 0 indicates a successful exit.
*>        If INFO < 0, argument number -INFO is illegal.
*>        If INFO > 0, the algorithm did not converge, and INFO
*>        specifies how many superdiagonals did not converge.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee 
*> \author Univ. of California Berkeley 
*> \author Univ. of Colorado Denver 
*> \author NAG Ltd. 
*
*> \date June 2016
*
*> \ingroup auxOTHERauxiliary
*
*> \par Contributors:
*  ==================
*>
*>     Ming Gu and Huan Ren, Computer Science Division, University of
*>     California at Berkeley, USA
*>
*  =====================================================================
      SUBROUTINE slasdq( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
     $                   u, ldu, c, ldc, work, info )
*
*  -- LAPACK auxiliary routine (version 3.6.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
*     ..
*     .. Array Arguments ..
      REAL               C( ldc, * ), D( * ), E( * ), U( ldu, * ),
     $                   vt( ldvt, * ), work( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter                ( zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
      REAL               CS, R, SMIN, SN
*     ..
*     .. External Subroutines ..
      EXTERNAL           sbdsqr, slartg, slasr, sswap, xerbla
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      iuplo = 0
      IF( lsame( uplo, 'U' ) )
     $   iuplo = 1
      IF( lsame( uplo, 'L' ) )
     $   iuplo = 2
      IF( iuplo.EQ.0 ) THEN
         info = -1
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( ncvt.LT.0 ) THEN
         info = -4
      ELSE IF( nru.LT.0 ) THEN
         info = -5
      ELSE IF( ncc.LT.0 ) THEN
         info = -6
      ELSE IF( ( ncvt.EQ.0 .AND. ldvt.LT.1 ) .OR.
     $         ( ncvt.GT.0 .AND. ldvt.LT.max( 1, n ) ) ) THEN
         info = -10
      ELSE IF( ldu.LT.max( 1, nru ) ) THEN
         info = -12
      ELSE IF( ( ncc.EQ.0 .AND. ldc.LT.1 ) .OR.
     $         ( ncc.GT.0 .AND. ldc.LT.max( 1, n ) ) ) THEN
         info = -14
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASDQ', -info )
         RETURN
      END IF
      IF( n.EQ.0 )
     $   RETURN
*
*     ROTATE is true if any singular vectors desired, false otherwise
*
      rotate = ( ncvt.GT.0 ) .OR. ( nru.GT.0 ) .OR. ( ncc.GT.0 )
      np1 = n + 1
      sqre1 = sqre
*
*     If matrix non-square upper bidiagonal, rotate to be lower
*     bidiagonal.  The rotations are on the right.
*
      IF( ( iuplo.EQ.1 ) .AND. ( sqre1.EQ.1 ) ) THEN
         DO 10 i = 1, n - 1
            CALL slartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   10    CONTINUE
         CALL slartg( d( n ), e( n ), cs, sn, r )
         d( n ) = r
         e( n ) = zero
         IF( rotate ) THEN
            work( n ) = cs
            work( n+n ) = sn
         END IF
         iuplo = 2
         sqre1 = 0
*
*        Update singular vectors if desired.
*
         IF( ncvt.GT.0 )
     $      CALL slasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),
     $                  work( np1 ), vt, ldvt )
      END IF
*
*     If matrix lower bidiagonal, rotate to be upper bidiagonal
*     by applying Givens rotations on the left.
*
      IF( iuplo.EQ.2 ) THEN
         DO 20 i = 1, n - 1
            CALL slartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   20    CONTINUE
*
*        If matrix (N+1)-by-N lower bidiagonal, one additional
*        rotation is needed.
*
         IF( sqre1.EQ.1 ) THEN
            CALL slartg( d( n ), e( n ), cs, sn, r )
            d( n ) = r
            IF( rotate ) THEN
               work( n ) = cs
               work( n+n ) = sn
            END IF
         END IF
*
*        Update singular vectors if desired.
*
         IF( nru.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL slasr( 'R', 'V', 'F', nru, n, work( 1 ),
     $                     work( np1 ), u, ldu )
            ELSE
               CALL slasr( 'R', 'V', 'F', nru, np1, work( 1 ),
     $                     work( np1 ), u, ldu )
            END IF
         END IF
         IF( ncc.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL slasr( 'L', 'V', 'F', n, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            ELSE
               CALL slasr( 'L', 'V', 'F', np1, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            END IF
         END IF
      END IF
*
*     Call SBDSQR to compute the SVD of the reduced real
*     N-by-N upper bidiagonal matrix.
*
      CALL sbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,
     $             ldc, work, info )
*
*     Sort the singular values into ascending order (insertion sort on
*     singular values, but only one transposition per singular vector)
*
      DO 40 i = 1, n
*
*        Scan for smallest D(I).
*
         isub = i
         smin = d( i )
         DO 30 j = i + 1, n
            IF( d( j ).LT.smin ) THEN
               isub = j
               smin = d( j )
            END IF
   30    CONTINUE
         IF( isub.NE.i ) THEN
*
*           Swap singular values and vectors.
*
            d( isub ) = d( i )
            d( i ) = smin
            IF( ncvt.GT.0 )
     $         CALL sswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt )
            IF( nru.GT.0 )
     $         CALL sswap( nru, u( 1, isub ), 1, u( 1, i ), 1 )
            IF( ncc.GT.0 )
     $         CALL sswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc )
         END IF
   40 CONTINUE
*
      RETURN
*
*     End of SLASDQ
*
      END