SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. 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( * )
* ..
*
* Purpose
* =======
*
* 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' (P' 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' * VT if desired.
* The input matrix C is changed to Q' * 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.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* On entry, UPLO specifies whether the input bidiagonal matrix
* is upper or lower bidiagonal, and wether it is square are
* not.
* UPLO = 'U' or 'u' B is upper bidiagonal.
* UPLO = 'L' or 'l' B is lower bidiagonal.
*
* SQRE (input) 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.
*
* N (input) INTEGER
* On entry, N specifies the number of rows and columns
* in the matrix. N must be at least 0.
*
* NCVT (input) INTEGER
* On entry, NCVT specifies the number of columns of
* the matrix VT. NCVT must be at least 0.
*
* NRU (input) INTEGER
* On entry, NRU specifies the number of rows of
* the matrix U. NRU must be at least 0.
*
* NCC (input) INTEGER
* On entry, NCC specifies the number of columns of
* the matrix C. NCC must be at least 0.
*
* D (input/output) 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.
*
* E (input/output) 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.
*
* VT (input/output) REAL array, dimension (LDVT, NCVT)
* On entry, contains a matrix which on exit has been
* premultiplied by P', dimension N-by-NCVT if SQRE = 0
* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
*
* LDVT (input) 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.
*
* U (input/output) 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).
*
* LDU (input) 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 ) .
*
* C (input/output) REAL array, dimension (LDC, NCC)
* On entry, contains an N-by-NCC matrix which on exit
* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
*
* LDC (input) 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.
*
* WORK (workspace) REAL array, dimension (4*N)
* Workspace. Only referenced if one of NCVT, NRU, or NCC is
* nonzero, and if N is at least 2.
*
* INFO (output) 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.
*
* Further Details
* ===============
*
* Based on contributions by
* Ming Gu and Huan Ren, Computer Science Division, University of
* California at Berkeley, USA
*
* =====================================================================
*
* .. 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