Move LAPACK trunk into position.

1 files changed, 316 insertions, 0 deletions

diff --git a/SRC/dlasdq.f b/SRC/dlasdq.f
new file mode 100644
index 00000000..08f7e8f8
--- /dev/null
+++ b/SRC/dlasdq.f
@@ -0,0 +1,316 @@
+      SUBROUTINE DLASDQ( 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 ..
+      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASDQ 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ROTATE
+      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
+      DOUBLE PRECISION   CS, R, SMIN, SN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSQR, DLARTG, DLASR, DSWAP, 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( 'DLASDQ', -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 DLARTG( 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 DLARTG( 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 DLASR( '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 DLARTG( 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 DLARTG( 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 DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
+     $                     WORK( NP1 ), U, LDU )
+            ELSE
+               CALL DLASR( '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 DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            ELSE
+               CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            END IF
+         END IF
+      END IF
+*
+*     Call DBDSQR to compute the SVD of the reduced real
+*     N-by-N upper bidiagonal matrix.
+*
+      CALL DBDSQR( '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 DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
+         END IF
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of DLASDQ
+*
+      END