sgesvdx.f

Go to the documentation of this file.

*> \brief <b> SGESVDX computes the singular value decomposition (SVD) for GE matrices</b>
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGESVDX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgesvdx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgesvdx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgesvdx.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*     SUBROUTINE SGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
*    $                    IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
*    $                    LWORK, IWORK, INFO )
*
*
*     .. Scalar Arguments ..
*      CHARACTER          JOBU, JOBVT, RANGE
*      INTEGER            IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
*      REAL               VL, VU
*     ..
*     .. Array Arguments ..
*     INTEGER            IWORK( * )
*     REAL               A( LDA, * ), S( * ), U( LDU, * ),
*    $                   VT( LDVT, * ), WORK( * )
*     ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>  SGESVDX computes the singular value decomposition (SVD) of a real
*>  M-by-N matrix A, optionally computing the left and/or right singular
*>  vectors. The SVD is written
*>
*>      A = U * SIGMA * transpose(V)
*>
*>  where SIGMA is an M-by-N matrix which is zero except for its
*>  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
*>  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
*>  are the singular values of A; they are real and non-negative, and
*>  are returned in descending order.  The first min(m,n) columns of
*>  U and V are the left and right singular vectors of A.
*>
*>  SGESVDX uses an eigenvalue problem for obtaining the SVD, which
*>  allows for the computation of a subset of singular values and
*>  vectors. See SBDSVDX for details.
*>
*>  Note that the routine returns V**T, not V.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBU
*> \verbatim
*>          JOBU is CHARACTER*1
*>          Specifies options for computing all or part of the matrix U:
*>          = 'V':  the first min(m,n) columns of U (the left singular
*>                  vectors) or as specified by RANGE are returned in
*>                  the array U;
*>          = 'N':  no columns of U (no left singular vectors) are
*>                  computed.
*> \endverbatim
*>
*> \param[in] JOBVT
*> \verbatim
*>          JOBVT is CHARACTER*1
*>           Specifies options for computing all or part of the matrix
*>           V**T:
*>           = 'V':  the first min(m,n) rows of V**T (the right singular
*>                   vectors) or as specified by RANGE are returned in
*>                   the array VT;
*>           = 'N':  no rows of V**T (no right singular vectors) are
*>                   computed.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': all singular values will be found.
*>          = 'V': all singular values in the half-open interval (VL,VU]
*>                 will be found.
*>          = 'I': the IL-th through IU-th singular values will be found.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the input matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the input matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the contents of A are destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*>          VL is REAL
*>          If RANGE='V', the lower bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*>          VU is REAL
*>          If RANGE='V', the upper bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>          If RANGE='I', the index of the
*>          smallest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>          If RANGE='I', the index of the
*>          largest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*>          NS is INTEGER
*>          The total number of singular values found,
*>          0 <= NS <= min(M,N).
*>          If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL array, dimension (min(M,N))
*>          The singular values of A, sorted so that S(i) >= S(i+1).
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is REAL array, dimension (LDU,UCOL)
*>          If JOBU = 'V', U contains columns of U (the left singular
*>          vectors, stored columnwise) as specified by RANGE; if
*>          JOBU = 'N', U is not referenced.
*>          Note: The user must ensure that UCOL >= NS; if RANGE = 'V',
*>          the exact value of NS is not known in advance and an upper
*>          bound must be used.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= 1; if
*>          JOBU = 'V', LDU >= M.
*> \endverbatim
*>
*> \param[out] VT
*> \verbatim
*>          VT is REAL array, dimension (LDVT,N)
*>          If JOBVT = 'V', VT contains the rows of V**T (the right singular
*>          vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N',
*>          VT is not referenced.
*>          Note: The user must ensure that LDVT >= NS; if RANGE = 'V',
*>          the exact value of NS is not known in advance and an upper
*>          bound must be used.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>          The leading dimension of the array VT.  LDVT >= 1; if
*>          JOBVT = 'V', LDVT >= NS (see above).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see
*>          comments inside the code):
*>             - PATH 1  (M much larger than N)
*>             - PATH 1t (N much larger than M)
*>          LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths.
*>          For good performance, LWORK should generally be larger.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (12*MIN(M,N))
*>          If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0,
*>          then IWORK contains the indices of the eigenvectors that failed
*>          to converge in SBDSVDX/SSTEVX.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>     INFO is INTEGER
*>           = 0:  successful exit
*>           < 0:  if INFO = -i, the i-th argument had an illegal value
*>           > 0:  if INFO = i, then i eigenvectors failed to converge
*>                 in SBDSVDX/SSTEVX.
*>                 if INFO = N*2 + 1, an internal error occurred in
*>                 SBDSVDX
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realGEsing
*
*  =====================================================================
      SUBROUTINE sgesvdx( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
     $                    IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
     $                    LWORK, IWORK, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOBU, JOBVT, RANGE
      INTEGER            IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
      REAL               VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               A( LDA, * ), S( * ), U( LDU, * ),
     $                   vt( ldvt, * ), work( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0e0, one = 1.0e0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          JOBZ, RNGTGK
      LOGICAL            ALLS, INDS, LQUERY, VALS, WANTU, WANTVT
      INTEGER            I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL,
     $                   itau, itaup, itauq, itemp, itgkz, iutgk,
     $                   j, maxwrk, minmn, minwrk, mnthr
      REAL               ABSTOL, ANRM, BIGNUM, EPS, SMLNUM
*     ..
*     .. Local Arrays ..
      REAL               DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           sbdsvdx, sgebrd, sgelqf, sgeqrf, slacpy,
     $                   slascl, slaset, sormbr, sormlq, sormqr,
     $                   scopy, xerbla
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH, SLANGE
      EXTERNAL           lsame, ilaenv, slamch, slange
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, min, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      ns = 0
      info = 0
      abstol = 2*slamch('S')
      lquery = ( lwork.EQ.-1 )
      minmn = min( m, n )
 
      wantu = lsame( jobu, 'V' )
      wantvt = lsame( jobvt, 'v' )
.OR.      IF( WANTU  WANTVT ) THEN
         JOBZ = 'v'
      ELSE
         JOBZ = 'n'
      END IF
      ALLS = LSAME( RANGE, 'a' )
      VALS = LSAME( RANGE, 'v' )
      inds = lsame( range, 'I' )
*
      info = 0
      IF( .NOT.lsame( jobu, 'V' ) .AND.
     $    .NOT.lsame( jobu, 'N' ) ) THEN
         info = -1
      ELSE IF( .NOT.lsame( jobvt, 'V' ) .AND.
     $         .NOT.lsame( jobvt, 'N' ) ) THEN
         info = -2
      ELSE IF( .NOT.( alls .OR. vals .OR. inds ) ) THEN
         info = -3
      ELSE IF( m.LT.0 ) THEN
         info = -4
      ELSE IF( n.LT.0 ) THEN
         info = -5
      ELSE IF( m.GT.lda ) THEN
         info = -7
      ELSE IF( minmn.GT.0 ) THEN
         IF( vals ) THEN
            IF( vl.LT.zero ) THEN
               info = -8
            ELSE IF( vu.LE.vl ) THEN
               info = -9
            END IF
         ELSE IF( inds ) THEN
            IF( il.LT.1 .OR. il.GT.max( 1, minmn ) ) THEN
               info = -10
            ELSE IF( iu.LT.min( minmn, il ) .OR. iu.GT.minmn ) THEN
               info = -11
            END IF
         END IF
         IF( info.EQ.0 ) THEN
            IF( wantu .AND. ldu.LT.m ) THEN
               info = -15
            ELSE IF( wantvt ) THEN
               IF( inds ) THEN
                   IF( ldvt.LT.iu-il+1 ) THEN
                       info = -17
                   END IF
               ELSE IF( ldvt.LT.minmn ) THEN
                   info = -17
               END IF
            END IF
         END IF
      END IF
*
*     Compute workspace
*     (Note: Comments in the code beginning "Workspace:" describe the
*     minimal amount of workspace needed at that point in the code,
*     as well as the preferred amount for good performance.
*     NB refers to the optimal block size for the immediately
*     following subroutine, as returned by ILAENV.)
*
      IF( info.EQ.0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF( minmn.GT.0 ) THEN
            IF( m.GE.n ) THEN
               mnthr = ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 )
               IF( m.GE.mnthr ) THEN
*
*                 Path 1 (M much larger than N)
*
                  maxwrk = n +
     $                     n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 )
                  maxwrk = max( maxwrk, n*(n+5) + 2*n*
     $                     ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) )
                  IF (wantu) THEN
                      maxwrk = max(maxwrk,n*(n*3+6)+n*
     $                     ilaenv( 1, 'SORMQR', ' ', n, n, -1, -1 ) )
                  END IF
                  IF (wantvt) THEN
                      maxwrk = max(maxwrk,n*(n*3+6)+n*
     $                     ilaenv( 1, 'SORMLQ', ' ', n, n, -1, -1 ) )
                  END IF
                  minwrk = n*(n*3+20)
               ELSE
*
*                 Path 2 (M at least N, but not much larger)
*
                  maxwrk = 4*n + ( m+n )*
     $                     ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 )
                  IF (wantu) THEN
                      maxwrk = max(maxwrk,n*(n*2+5)+n*
     $                     ilaenv( 1, 'SORMQR', ' ', n, n, -1, -1 ) )
                  END IF
                  IF (wantvt) THEN
                      maxwrk = max(maxwrk,n*(n*2+5)+n*
     $                     ilaenv( 1, 'SORMLQ', ' ', n, n, -1, -1 ) )
                  END IF
                  minwrk = max(n*(n*2+19),4*n+m)
               END IF
            ELSE
               mnthr = ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 )
               IF( n.GE.mnthr ) THEN
*
*                 Path 1t (N much larger than M)
*
                  maxwrk = m +
     $                     m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 )
                  maxwrk = max( maxwrk, m*(m+5) + 2*m*
     $                     ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) )
                  IF (wantu) THEN
                      maxwrk = max(maxwrk,m*(m*3+6)+m*
     $                     ilaenv( 1, 'SORMQR', ' ', m, m, -1, -1 ) )
                  END IF
                  IF (wantvt) THEN
                      maxwrk = max(maxwrk,m*(m*3+6)+m*
     $                     ilaenv( 1, 'SORMLQ', ' ', m, m, -1, -1 ) )
                  END IF
                  minwrk = m*(m*3+20)
               ELSE
*
*                 Path 2t (N at least M, but not much larger)
*
                  maxwrk = 4*m + ( m+n )*
     $                     ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 )
                  IF (wantu) THEN
                      maxwrk = max(maxwrk,m*(m*2+5)+m*
     $                     ilaenv( 1, 'SORMQR', ' ', m, m, -1, -1 ) )
                  END IF
                  IF (wantvt) THEN
                      maxwrk = max(maxwrk,m*(m*2+5)+m*
     $                     ilaenv( 1, 'SORMLQ', ' ', M, M, -1, -1 ) )
                  END IF
                  MINWRK = MAX(M*(M*2+19),4*M+N)
               END IF
            END IF
         END IF
         MAXWRK = MAX( MAXWRK, MINWRK )
         WORK( 1 ) = REAL( MAXWRK )
*
.LT..AND..NOT.         IF( LWORKMINWRK  LQUERY ) THEN
             INFO = -19
         END IF
      END IF
*
.NE.      IF( INFO0 ) THEN
         CALL XERBLA( 'sgesvdx', -info )
         RETURN
      ELSE IF( lquery ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( m.EQ.0 .OR. n.EQ.0 ) THEN
         RETURN
      END IF
*
*     Set singular values indices accord to RANGE.
*
      IF( alls ) THEN
         rngtgk = 'I'
         iltgk = 1
         iutgk = min( m, n )
      ELSE IF( inds ) THEN
         rngtgk = 'I'
         iltgk = il
         iutgk = iu
      ELSE
         rngtgk = 'V'
         iltgk = 0
         iutgk = 0
      END IF
*
*     Get machine constants
*
      eps = slamch( 'P' )
      smlnum = sqrt( slamch( 'S' ) ) / eps
      bignum = one / smlnum
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      anrm = slange( 'M', m, n, a, lda, dum )
      iscl = 0
      IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
         iscl = 1
         CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
      ELSE IF( anrm.GT.bignum ) THEN
         iscl = 1
         CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info )
      END IF
*
      IF( m.GE.n ) THEN
*
*        A has at least as many rows as columns. If A has sufficiently
*        more rows than columns, first reduce A using the QR
*        decomposition.
*
         IF( m.GE.mnthr ) THEN
*
*           Path 1 (M much larger than N):
*           A = Q * R = Q * ( QB * B * PB**T )
*                     = Q * ( QB * ( UB * S * VB**T ) * PB**T )
*           U = Q * QB * UB; V**T = VB**T * PB**T
*
*           Compute A=Q*R
*           (Workspace: need 2*N, prefer N+N*NB)
*
            itau = 1
            itemp = itau + n
            CALL sgeqrf( m, n, a, lda, work( itau ), work( itemp ),
     $                   lwork-itemp+1, info )
*
*           Copy R into WORK and bidiagonalize it:
*           (Workspace: need N*N+5*N, prefer N*N+4*N+2*N*NB)
*
            iqrf = itemp
            id = iqrf + n*n
            ie = id + n
            itauq = ie + n
            itaup = itauq + n
            itemp = itaup + n
            CALL slacpy( 'U', n, n, a, lda, work( iqrf ), n )
            CALL slaset( 'L', n-1, n-1, zero, zero, work( iqrf+1 ), n )
            CALL sgebrd( n, n, work( iqrf ), n, work( id ), work( ie ),
     $                   work( itauq ), work( itaup ), work( itemp ),
     $                   lwork-itemp+1, info )
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 14*N + 2*N*(N+1))
*
            itgkz = itemp
            itemp = itgkz + n*(n*2+1)
            CALL sbdsvdx( 'U', jobz, rngtgk, n, work( id ), work( ie ),
     $                    vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
     $                    n*2, work( itemp ), iwork, info)
*
*           If needed, compute left singular vectors.
*
            IF( wantu ) THEN
               j = itgkz
               DO i = 1, ns
                  CALL scopy( n, work( j ), 1, u( 1,i ), 1 )
                  j = j + n*2
               END DO
               CALL slaset( 'A', m-n, ns, zero, zero, u( n+1,1 ), ldu )
*
*              Call SORMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL sormbr( 'Q', 'L', 'N', n, ns, n, work( iqrf ), n,
     $                      work( itauq ), u, ldu, work( itemp ),
     $                      lwork-itemp+1, info )
*
*              Call SORMQR to compute Q*(QB*UB).
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL sormqr( 'L', 'N', m, ns, n, a, lda,
     $                      work( itau ), u, ldu, work( itemp ),
     $                      lwork-itemp+1, info )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( wantvt) THEN
               j = itgkz + n
               DO i = 1, ns
                  CALL scopy( n, work( j ), 1, vt( i,1 ), ldvt )
                  j = j + n*2
               END DO
*
*              Call SORMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL sormbr( 'P', 'R', 'T', ns, n, n, work( iqrf ), n,
     $                      work( itaup ), vt, ldvt, work( itemp ),
     $                      lwork-itemp+1, info )
            END IF
         ELSE
*
*           Path 2 (M at least N, but not much larger)
*           Reduce A to bidiagonal form without QR decomposition
*           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
*           U = QB * UB; V**T = VB**T * PB**T
*
*           Bidiagonalize A
*           (Workspace: need 4*N+M, prefer 4*N+(M+N)*NB)
*
            id = 1
            ie = id + n
            itauq = ie + n
            itaup = itauq + n
            itemp = itaup + n
            CALL sgebrd( m, n, a, lda, work( id ), work( ie ),
     $                   work( itauq ), work( itaup ), work( itemp ),
     $                   lwork-itemp+1, info )
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 14*N + 2*N*(N+1))
*
            itgkz = itemp
            itemp = itgkz + n*(n*2+1)
            CALL sbdsvdx( 'U', jobz, rngtgk, n, work( id ), work( ie ),
     $                    vl, vu, iltgk, iutgk, ns, s, work( itgkz ),
     $                    n*2, work( itemp ), iwork, info)
*
*           If needed, compute left singular vectors.
*
            IF( wantu ) THEN
               j = itgkz
               DO i = 1, ns
                  CALL scopy( n, work( j ), 1, u( 1,i ), 1 )
                  j = j + n*2
               END DO
               CALL slaset( 'A', m-n, ns, zero, zero, u( n+1,1 ), ldu )
*
*              Call SORMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL sormbr( 'Q', 'L', 'N', m, ns, n, a, lda,
     $                      work( itauq ), u, ldu, work( itemp ),
     $                      lwork-itemp+1, ierr )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( wantvt) THEN
               j = itgkz + n
               DO i = 1, ns
                  CALL scopy( n, work( j ), 1, vt( i,1 ), ldvt )
                  j = j + n*2
               END DO
*
*              Call SORMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL sormbr( 'P', 'R', 'T', ns, n, n, a, lda,
     $                      work( itaup ), vt, ldvt, work( itemp ),
     $                      lwork-itemp+1, ierr )
            END IF
         END IF
      ELSE
*
*        A has more columns than rows. If A has sufficiently more
*        columns than rows, first reduce A using the LQ decomposition.
*
         IF( n.GE.mnthr ) THEN
*
*           Path 1t (N much larger than M):
*           A = L * Q = ( QB * B * PB**T ) * Q
*                     = ( QB * ( UB * S * VB**T ) * PB**T ) * Q
*           U = QB * UB ; V**T = VB**T * PB**T * Q
*
*           Compute A=L*Q
*           (Workspace: need 2*M, prefer M+M*NB)
*
            itau = 1
            itemp = itau + m
            CALL sgelqf( m, n, a, lda, work( itau ), work( itemp ),
     $                   lwork-itemp+1, info )
 
*           Copy L into WORK and bidiagonalize it:
*           (Workspace in WORK( ITEMP ): need M*M+5*N, prefer M*M+4*M+2*M*NB)
*
            ilqf = itemp
            id = ilqf + m*m
            ie = id + m
            itauq = ie + m
            itaup = itauq + m
            itemp = itaup + m
            CALL slacpy( 'L', m, m, a, lda, work( ilqf ), m )
            CALL slaset( 'u', M-1, M-1, ZERO, ZERO, WORK( ILQF+M ), M )
            CALL SGEBRD( M, M, WORK( ILQF ), M, WORK( ID ), WORK( IE ),
     $                   WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*M*M+14*M)
*
            ITGKZ = ITEMP
            ITEMP = ITGKZ + M*(M*2+1)
            CALL SBDSVDX( 'u', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ),
     $                    VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ),
     $                    M*2, WORK( ITEMP ), IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               J = ITGKZ
               DO I = 1, NS
                  CALL SCOPY( M, WORK( J ), 1, U( 1,I ), 1 )
                  J = J + M*2
               END DO
*
*              Call SORMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL SORMBR( 'q', 'l', 'n', M, NS, M, WORK( ILQF ), M,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               J = ITGKZ + M
               DO I = 1, NS
                  CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT )
                  J = J + M*2
               END DO
               CALL SLASET( 'a', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT)
*
*              Call SORMBR to compute (VB**T)*(PB**T)
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL SORMBR( 'p', 'r', 't', NS, M, M, WORK( ILQF ), M,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
*
*              Call SORMLQ to compute ((VB**T)*(PB**T))*Q.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL SORMLQ( 'r', 'n', NS, N, M, A, LDA,
     $                      WORK( ITAU ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
         ELSE
*
*           Path 2t (N greater than M, but not much larger)
*           Reduce to bidiagonal form without LQ decomposition
*           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
*           U = QB * UB; V**T = VB**T * PB**T
*
*           Bidiagonalize A
*           (Workspace: need 4*M+N, prefer 4*M+(M+N)*NB)
*
            ID = 1
            IE = ID + M
            ITAUQ = IE + M
            ITAUP = ITAUQ + M
            ITEMP = ITAUP + M
            CALL SGEBRD( M, N, A, LDA, WORK( ID ), WORK( IE ),
     $                   WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*M*M+14*M)
*
            ITGKZ = ITEMP
            ITEMP = ITGKZ + M*(M*2+1)
            CALL SBDSVDX( 'l', JOBZ, RNGTGK, M, WORK( ID ), WORK( IE ),
     $                    VL, VU, ILTGK, IUTGK, NS, S, WORK( ITGKZ ),
     $                    M*2, WORK( ITEMP ), IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               J = ITGKZ
               DO I = 1, NS
                  CALL SCOPY( M, WORK( J ), 1, U( 1,I ), 1 )
                  J = J + M*2
               END DO
*
*              Call SORMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL SORMBR( 'q', 'l', 'n', M, NS, N, A, LDA,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               J = ITGKZ + M
               DO I = 1, NS
                  CALL SCOPY( M, WORK( J ), 1, VT( I,1 ), LDVT )
                  J = J + M*2
               END DO
               CALL SLASET( 'a', NS, N-M, ZERO, ZERO, VT( 1,M+1 ), LDVT)
*
*              Call SORMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL SORMBR( 'p', 'r', 't', NS, N, M, A, LDA,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
         END IF
      END IF
*
*     Undo scaling if necessary
*
.EQ.      IF( ISCL1 ) THEN
.GT.         IF( ANRMBIGNUM )
     $      CALL SLASCL( 'g', 0, 0, BIGNUM, ANRM, MINMN, 1,
     $                   S, MINMN, INFO )
.LT.         IF( ANRMSMLNUM )
     $      CALL SLASCL( 'g', 0, 0, SMLNUM, ANRM, MINMN, 1,
     $                   S, MINMN, INFO )
      END IF
*
*     Return optimal workspace in WORK(1)
*
      WORK( 1 ) = REAL( MAXWRK )
*
      RETURN
*
*     End of SGESVDX
*
      END