!*==cgesdd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CGESDD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGESDD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT,
!                          WORK, LWORK, RWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ
!       INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       REAL               RWORK( * ), S( * )
!       COMPLEX            A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGESDD computes the singular value decomposition (SVD) of a complex
!> M-by-N matrix A, optionally computing the left and/or right singular
!> vectors, by using divide-and-conquer method. The SVD is written
!>
!>      A = U * SIGMA * conjugate-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 unitary matrix, and
!> V is an N-by-N unitary 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.
!>
!> Note that the routine returns VT = V**H, not V.
!>
!> The divide and conquer algorithm makes very mild assumptions about
!> floating point arithmetic. It will work on machines with a guard
!> digit in add/subtract, or on those binary machines without guard
!> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!> Cray-2. It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          Specifies options for computing all or part of the matrix U:
!>          = 'A':  all M columns of U and all N rows of V**H are
!>                  returned in the arrays U and VT;
!>          = 'S':  the first min(M,N) columns of U and the first
!>                  min(M,N) rows of V**H are returned in the arrays U
!>                  and VT;
!>          = 'O':  If M >= N, the first N columns of U are overwritten
!>                  in the array A and all rows of V**H are returned in
!>                  the array VT;
!>                  otherwise, all columns of U are returned in the
!>                  array U and the first M rows of V**H are overwritten
!>                  in the array A;
!>          = 'N':  no columns of U or rows of V**H are computed.
!> \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 COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>          if JOBZ = 'O',  A is overwritten with the first N columns
!>                          of U (the left singular vectors, stored
!>                          columnwise) if M >= N;
!>                          A is overwritten with the first M rows
!>                          of V**H (the right singular vectors, stored
!>                          rowwise) otherwise.
!>          if JOBZ .ne. 'O', 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[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 COMPLEX array, dimension (LDU,UCOL)
!>          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
!>          UCOL = min(M,N) if JOBZ = 'S'.
!>          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
!>          unitary matrix U;
!>          if JOBZ = 'S', U contains the first min(M,N) columns of U
!>          (the left singular vectors, stored columnwise);
!>          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1;
!>          if JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
!> \endverbatim
!>
!> \param[out] VT
!> \verbatim
!>          VT is COMPLEX array, dimension (LDVT,N)
!>          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
!>          N-by-N unitary matrix V**H;
!>          if JOBZ = 'S', VT contains the first min(M,N) rows of
!>          V**H (the right singular vectors, stored rowwise);
!>          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1;
!>          if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
!>          if JOBZ = 'S', LDVT >= min(M,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX 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 >= 1.
!>          If LWORK = -1, a workspace query is assumed.  The optimal
!>          size for the WORK array is calculated and stored in WORK(1),
!>          and no other work except argument checking is performed.
!>
!>          Let mx = max(M,N) and mn = min(M,N).
!>          If JOBZ = 'N', LWORK >= 2*mn + mx.
!>          If JOBZ = 'O', LWORK >= 2*mn*mn + 2*mn + mx.
!>          If JOBZ = 'S', LWORK >=   mn*mn + 3*mn.
!>          If JOBZ = 'A', LWORK >=   mn*mn + 2*mn + mx.
!>          These are not tight minimums in all cases; see comments inside code.
!>          For good performance, LWORK should generally be larger;
!>          a query is recommended.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (MAX(1,LRWORK))
!>          Let mx = max(M,N) and mn = min(M,N).
!>          If JOBZ = 'N',    LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn);
!>          else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn;
!>          else              LRWORK >= max( 5*mn*mn + 5*mn,
!>                                           2*mx*mn + 2*mn*mn + mn ).
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (8*min(M,N))
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The updating process of SBDSDC 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 complexGEsing
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Huan Ren, Computer Science Division, University of
!>     California at Berkeley, USA
!>
!  =====================================================================
      SUBROUTINE CGESDD(Jobz,M,N,A,Lda,S,U,Ldu,Vt,Ldvt,Work,Lwork,Rwork,&
     &                  Iwork,Info)
      IMPLICIT NONE
!*--CGESDD230
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- 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 Jobz
      INTEGER Info , Lda , Ldu , Ldvt , Lwork , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      REAL Rwork(*) , S(*)
      COMPLEX A(Lda,*) , U(Ldu,*) , Vt(Ldvt,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX CZERO , CONE
      PARAMETER (CZERO=(0.0E+0,0.0E+0),CONE=(1.0E+0,0.0E+0))
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , wntqa , wntqas , wntqn , wntqo , wntqs
      INTEGER blk , chunk , i , ie , ierr , il , ir , iru , irvt ,      &
     &        iscl , itau , itaup , itauq , iu , ivt , ldwkvt , ldwrkl ,&
     &        ldwrkr , ldwrku , maxwrk , minmn , minwrk , mnthr1 ,      &
     &        mnthr2 , nrwork , nwork , wrkbl
      INTEGER lwork_cgebrd_mn , lwork_cgebrd_mm , lwork_cgebrd_nn ,     &
     &        lwork_cgelqf_mn , lwork_cgeqrf_mn , lwork_cungbr_p_mn ,   &
     &        lwork_cungbr_p_nn , lwork_cungbr_q_mn ,                   &
     &        lwork_cungbr_q_mm , lwork_cunglq_mn , lwork_cunglq_nn ,   &
     &        lwork_cungqr_mm , lwork_cungqr_mn , lwork_cunmbr_prc_mm , &
     &        lwork_cunmbr_qln_mm , lwork_cunmbr_prc_mn ,               &
     &        lwork_cunmbr_qln_mn , lwork_cunmbr_prc_nn ,               &
     &        lwork_cunmbr_qln_nn
      REAL anrm , bignum , eps , smlnum
!     ..
!     .. Local Arrays ..
      INTEGER idum(1)
      REAL dum(1)
      COMPLEX cdum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEBRD , CGELQF , CGEMM , CGEQRF , CLACP2 , CLACPY ,     &
     &         CLACRM , CLARCM , CLASCL , CLASET , CUNGBR , CUNGLQ ,    &
     &         CUNGQR , CUNMBR , SBDSDC , SLASCL , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME , SISNAN
      REAL SLAMCH , CLANGE
      EXTERNAL LSAME , SLAMCH , CLANGE , SISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC INT , MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      minmn = MIN(M,N)
      mnthr1 = INT(minmn*17.0E0/9.0E0)
      mnthr2 = INT(minmn*5.0E0/3.0E0)
      wntqa = LSAME(Jobz,'A')
      wntqs = LSAME(Jobz,'S')
      wntqas = wntqa .OR. wntqs
      wntqo = LSAME(Jobz,'O')
      wntqn = LSAME(Jobz,'N')
      lquery = (Lwork==-1)
      minwrk = 1
      maxwrk = 1
!
      IF ( .NOT.(wntqa .OR. wntqs .OR. wntqo .OR. wntqn) ) THEN
         Info = -1
      ELSEIF ( M<0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldu<1 .OR. (wntqas .AND. Ldu<M) .OR.                     &
     &         (wntqo .AND. M<N .AND. Ldu<M) ) THEN
         Info = -8
      ELSEIF ( Ldvt<1 .OR. (wntqa .AND. Ldvt<N) .OR.                    &
     &         (wntqs .AND. Ldvt<minmn) .OR.                            &
     &         (wntqo .AND. M>=N .AND. Ldvt<N) ) THEN
         Info = -10
      ENDIF
!
!     Compute workspace
!       Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace allocated at that point in the code,
!       as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace to
!       real workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF ( M>=N .AND. minmn>0 ) THEN
!
!           There is no complex work space needed for bidiagonal SVD
!           The real work space needed for bidiagonal SVD (sbdsdc) is
!           BDSPAC = 3*N*N + 4*N for singular values and vectors;
!           BDSPAC = 4*N         for singular values only;
!           not including e, RU, and RVT matrices.
!
!           Compute space preferred for each routine
            CALL CGEBRD(M,N,cdum(1),M,dum(1),dum(1),cdum(1),cdum(1),    &
     &                  cdum(1),-1,ierr)
            lwork_cgebrd_mn = INT(cdum(1))
!
            CALL CGEBRD(N,N,cdum(1),N,dum(1),dum(1),cdum(1),cdum(1),    &
     &                  cdum(1),-1,ierr)
            lwork_cgebrd_nn = INT(cdum(1))
!
            CALL CGEQRF(M,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cgeqrf_mn = INT(cdum(1))
!
            CALL CUNGBR('P',N,N,N,cdum(1),N,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_p_nn = INT(cdum(1))
!
            CALL CUNGBR('Q',M,M,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_q_mm = INT(cdum(1))
!
            CALL CUNGBR('Q',M,N,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_q_mn = INT(cdum(1))
!
            CALL CUNGQR(M,M,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungqr_mm = INT(cdum(1))
!
            CALL CUNGQR(M,N,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungqr_mn = INT(cdum(1))
!
            CALL CUNMBR('P','R','C',N,N,N,cdum(1),N,cdum(1),cdum(1),N,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_prc_nn = INT(cdum(1))
!
            CALL CUNMBR('Q','L','N',M,M,N,cdum(1),M,cdum(1),cdum(1),M,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_qln_mm = INT(cdum(1))
!
            CALL CUNMBR('Q','L','N',M,N,N,cdum(1),M,cdum(1),cdum(1),M,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_qln_mn = INT(cdum(1))
!
            CALL CUNMBR('Q','L','N',N,N,N,cdum(1),N,cdum(1),cdum(1),N,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_qln_nn = INT(cdum(1))
!
            IF ( M>=mnthr1 ) THEN
               IF ( wntqn ) THEN
!
!                 Path 1 (M >> N, JOBZ='N')
!
                  maxwrk = N + lwork_cgeqrf_mn
                  maxwrk = MAX(maxwrk,2*N+lwork_cgebrd_nn)
                  minwrk = 3*N
               ELSEIF ( wntqo ) THEN
!
!                 Path 2 (M >> N, JOBZ='O')
!
                  wrkbl = N + lwork_cgeqrf_mn
                  wrkbl = MAX(wrkbl,N+lwork_cungqr_mn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cgebrd_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_qln_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_prc_nn)
                  maxwrk = M*N + N*N + wrkbl
                  minwrk = 2*N*N + 3*N
               ELSEIF ( wntqs ) THEN
!
!                 Path 3 (M >> N, JOBZ='S')
!
                  wrkbl = N + lwork_cgeqrf_mn
                  wrkbl = MAX(wrkbl,N+lwork_cungqr_mn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cgebrd_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_qln_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_prc_nn)
                  maxwrk = N*N + wrkbl
                  minwrk = N*N + 3*N
               ELSEIF ( wntqa ) THEN
!
!                 Path 4 (M >> N, JOBZ='A')
!
                  wrkbl = N + lwork_cgeqrf_mn
                  wrkbl = MAX(wrkbl,N+lwork_cungqr_mm)
                  wrkbl = MAX(wrkbl,2*N+lwork_cgebrd_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_qln_nn)
                  wrkbl = MAX(wrkbl,2*N+lwork_cunmbr_prc_nn)
                  maxwrk = N*N + wrkbl
                  minwrk = N*N + MAX(3*N,N+M)
               ENDIF
            ELSEIF ( M>=mnthr2 ) THEN
!
!              Path 5 (M >> N, but not as much as MNTHR1)
!
               maxwrk = 2*N + lwork_cgebrd_mn
               minwrk = 2*N + M
               IF ( wntqo ) THEN
!                 Path 5o (M >> N, JOBZ='O')
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_p_nn)
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_q_mn)
                  maxwrk = maxwrk + M*N
                  minwrk = minwrk + N*N
               ELSEIF ( wntqs ) THEN
!                 Path 5s (M >> N, JOBZ='S')
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_p_nn)
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_q_mn)
               ELSEIF ( wntqa ) THEN
!                 Path 5a (M >> N, JOBZ='A')
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_p_nn)
                  maxwrk = MAX(maxwrk,2*N+lwork_cungbr_q_mm)
               ENDIF
            ELSE
!
!              Path 6 (M >= N, but not much larger)
!
               maxwrk = 2*N + lwork_cgebrd_mn
               minwrk = 2*N + M
               IF ( wntqo ) THEN
!                 Path 6o (M >= N, JOBZ='O')
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_prc_nn)
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_qln_mn)
                  maxwrk = maxwrk + M*N
                  minwrk = minwrk + N*N
               ELSEIF ( wntqs ) THEN
!                 Path 6s (M >= N, JOBZ='S')
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_qln_mn)
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_prc_nn)
               ELSEIF ( wntqa ) THEN
!                 Path 6a (M >= N, JOBZ='A')
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_qln_mm)
                  maxwrk = MAX(maxwrk,2*N+lwork_cunmbr_prc_nn)
               ENDIF
            ENDIF
         ELSEIF ( minmn>0 ) THEN
!
!           There is no complex work space needed for bidiagonal SVD
!           The real work space needed for bidiagonal SVD (sbdsdc) is
!           BDSPAC = 3*M*M + 4*M for singular values and vectors;
!           BDSPAC = 4*M         for singular values only;
!           not including e, RU, and RVT matrices.
!
!           Compute space preferred for each routine
            CALL CGEBRD(M,N,cdum(1),M,dum(1),dum(1),cdum(1),cdum(1),    &
     &                  cdum(1),-1,ierr)
            lwork_cgebrd_mn = INT(cdum(1))
!
            CALL CGEBRD(M,M,cdum(1),M,dum(1),dum(1),cdum(1),cdum(1),    &
     &                  cdum(1),-1,ierr)
            lwork_cgebrd_mm = INT(cdum(1))
!
            CALL CGELQF(M,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cgelqf_mn = INT(cdum(1))
!
            CALL CUNGBR('P',M,N,M,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_p_mn = INT(cdum(1))
!
            CALL CUNGBR('P',N,N,M,cdum(1),N,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_p_nn = INT(cdum(1))
!
            CALL CUNGBR('Q',M,M,N,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cungbr_q_mm = INT(cdum(1))
!
            CALL CUNGLQ(M,N,M,cdum(1),M,cdum(1),cdum(1),-1,ierr)
            lwork_cunglq_mn = INT(cdum(1))
!
            CALL CUNGLQ(N,N,M,cdum(1),N,cdum(1),cdum(1),-1,ierr)
            lwork_cunglq_nn = INT(cdum(1))
!
            CALL CUNMBR('P','R','C',M,M,M,cdum(1),M,cdum(1),cdum(1),M,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_prc_mm = INT(cdum(1))
!
            CALL CUNMBR('P','R','C',M,N,M,cdum(1),M,cdum(1),cdum(1),M,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_prc_mn = INT(cdum(1))
!
            CALL CUNMBR('P','R','C',N,N,M,cdum(1),N,cdum(1),cdum(1),N,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_prc_nn = INT(cdum(1))
!
            CALL CUNMBR('Q','L','N',M,M,M,cdum(1),M,cdum(1),cdum(1),M,  &
     &                  cdum(1),-1,ierr)
            lwork_cunmbr_qln_mm = INT(cdum(1))
!
            IF ( N>=mnthr1 ) THEN
               IF ( wntqn ) THEN
!
!                 Path 1t (N >> M, JOBZ='N')
!
                  maxwrk = M + lwork_cgelqf_mn
                  maxwrk = MAX(maxwrk,2*M+lwork_cgebrd_mm)
                  minwrk = 3*M
               ELSEIF ( wntqo ) THEN
!
!                 Path 2t (N >> M, JOBZ='O')
!
                  wrkbl = M + lwork_cgelqf_mn
                  wrkbl = MAX(wrkbl,M+lwork_cunglq_mn)
                  wrkbl = MAX(wrkbl,2*M+lwork_cgebrd_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_qln_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_prc_mm)
                  maxwrk = M*N + M*M + wrkbl
                  minwrk = 2*M*M + 3*M
               ELSEIF ( wntqs ) THEN
!
!                 Path 3t (N >> M, JOBZ='S')
!
                  wrkbl = M + lwork_cgelqf_mn
                  wrkbl = MAX(wrkbl,M+lwork_cunglq_mn)
                  wrkbl = MAX(wrkbl,2*M+lwork_cgebrd_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_qln_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_prc_mm)
                  maxwrk = M*M + wrkbl
                  minwrk = M*M + 3*M
               ELSEIF ( wntqa ) THEN
!
!                 Path 4t (N >> M, JOBZ='A')
!
                  wrkbl = M + lwork_cgelqf_mn
                  wrkbl = MAX(wrkbl,M+lwork_cunglq_nn)
                  wrkbl = MAX(wrkbl,2*M+lwork_cgebrd_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_qln_mm)
                  wrkbl = MAX(wrkbl,2*M+lwork_cunmbr_prc_mm)
                  maxwrk = M*M + wrkbl
                  minwrk = M*M + MAX(3*M,M+N)
               ENDIF
            ELSEIF ( N>=mnthr2 ) THEN
!
!              Path 5t (N >> M, but not as much as MNTHR1)
!
               maxwrk = 2*M + lwork_cgebrd_mn
               minwrk = 2*M + N
               IF ( wntqo ) THEN
!                 Path 5to (N >> M, JOBZ='O')
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_q_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_p_mn)
                  maxwrk = maxwrk + M*N
                  minwrk = minwrk + M*M
               ELSEIF ( wntqs ) THEN
!                 Path 5ts (N >> M, JOBZ='S')
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_q_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_p_mn)
               ELSEIF ( wntqa ) THEN
!                 Path 5ta (N >> M, JOBZ='A')
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_q_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cungbr_p_nn)
               ENDIF
            ELSE
!
!              Path 6t (N > M, but not much larger)
!
               maxwrk = 2*M + lwork_cgebrd_mn
               minwrk = 2*M + N
               IF ( wntqo ) THEN
!                 Path 6to (N > M, JOBZ='O')
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_qln_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_prc_mn)
                  maxwrk = maxwrk + M*N
                  minwrk = minwrk + M*M
               ELSEIF ( wntqs ) THEN
!                 Path 6ts (N > M, JOBZ='S')
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_qln_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_prc_mn)
               ELSEIF ( wntqa ) THEN
!                 Path 6ta (N > M, JOBZ='A')
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_qln_mm)
                  maxwrk = MAX(maxwrk,2*M+lwork_cunmbr_prc_nn)
               ENDIF
            ENDIF
         ENDIF
         maxwrk = MAX(maxwrk,minwrk)
      ENDIF
      IF ( Info==0 ) THEN
         Work(1) = maxwrk
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGESDD',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Get machine constants
!
      eps = SLAMCH('P')
      smlnum = SQRT(SLAMCH('S'))/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = CLANGE('M',M,N,A,Lda,dum)
      IF ( SISNAN(anrm) ) THEN
         Info = -4
         RETURN
      ENDIF
      iscl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         iscl = 1
         CALL CLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,ierr)
      ELSEIF ( anrm>bignum ) THEN
         iscl = 1
         CALL CLASCL('G',0,0,anrm,bignum,M,N,A,Lda,ierr)
      ENDIF
!
      IF ( M>=N ) THEN
!
!        A has at least as many rows as columns. If A has sufficiently
!        more rows than columns, first reduce using the QR
!        decomposition (if sufficient workspace available)
!
         IF ( M>=mnthr1 ) THEN
!
            IF ( wntqn ) THEN
!
!              Path 1 (M >> N, JOBZ='N')
!              No singular vectors to be computed
!
               itau = 1
               nwork = itau + N
!
!              Compute A=Q*R
!              CWorkspace: need   N [tau] + N    [work]
!              CWorkspace: prefer N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CGEQRF(M,N,A,Lda,Work(itau),Work(nwork),            &
     &                     Lwork-nwork+1,ierr)
!
!              Zero out below R
!
               CALL CLASET('L',N-1,N-1,CZERO,CZERO,A(2,1),Lda)
               ie = 1
               itauq = 1
               itaup = itauq + N
               nwork = itaup + N
!
!              Bidiagonalize R in A
!              CWorkspace: need   2*N [tauq, taup] + N      [work]
!              CWorkspace: prefer 2*N [tauq, taup] + 2*N*NB [work]
!              RWorkspace: need   N [e]
!
               CALL CGEBRD(N,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup)&
     &                     ,Work(nwork),Lwork-nwork+1,ierr)
               nrwork = ie + N
!
!              Perform bidiagonal SVD, compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + BDSPAC
!
               CALL SBDSDC('U','N',N,S,Rwork(ie),dum,1,dum,1,dum,idum,  &
     &                     Rwork(nrwork),Iwork,Info)
!
            ELSEIF ( wntqo ) THEN
!
!              Path 2 (M >> N, JOBZ='O')
!              N left singular vectors to be overwritten on A and
!              N right singular vectors to be computed in VT
!
               iu = 1
!
!              WORK(IU) is N by N
!
               ldwrku = N
               ir = iu + ldwrku*N
               IF ( Lwork>=M*N+N*N+3*N ) THEN
!
!                 WORK(IR) is M by N
!
                  ldwrkr = M
               ELSE
                  ldwrkr = (Lwork-N*N-3*N)/N
               ENDIF
               itau = ir + ldwrkr*N
               nwork = itau + N
!
!              Compute A=Q*R
!              CWorkspace: need   N*N [U] + N*N [R] + N [tau] + N    [work]
!              CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CGEQRF(M,N,A,Lda,Work(itau),Work(nwork),            &
     &                     Lwork-nwork+1,ierr)
!
!              Copy R to WORK( IR ), zeroing out below it
!
               CALL CLACPY('U',N,N,A,Lda,Work(ir),ldwrkr)
               CALL CLASET('L',N-1,N-1,CZERO,CZERO,Work(ir+1),ldwrkr)
!
!              Generate Q in A
!              CWorkspace: need   N*N [U] + N*N [R] + N [tau] + N    [work]
!              CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CUNGQR(M,N,N,A,Lda,Work(itau),Work(nwork),          &
     &                     Lwork-nwork+1,ierr)
               ie = 1
               itauq = itau
               itaup = itauq + N
               nwork = itaup + N
!
!              Bidiagonalize R in WORK(IR)
!              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N      [work]
!              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
!              RWorkspace: need   N [e]
!
               CALL CGEBRD(N,N,Work(ir),ldwrkr,S,Rwork(ie),Work(itauq), &
     &                     Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of R in WORK(IRU) and computing right singular vectors
!              of R in WORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = ie + N
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
!              Overwrite WORK(IU) by the left singular vectors of R
!              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(iru),N,Work(iu),ldwrku)
               CALL CUNMBR('Q','L','N',N,N,N,Work(ir),ldwrkr,Work(itauq)&
     &                     ,Work(iu),ldwrku,Work(nwork),Lwork-nwork+1,  &
     &                     ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by the right singular vectors of R
!              CWorkspace: need   N*N [U] + N*N [R] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,Work(ir),ldwrkr,Work(itaup)&
     &                     ,Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IU), storing result in WORK(IR) and copying to A
!              CWorkspace: need   N*N [U] + N*N [R]
!              CWorkspace: prefer N*N [U] + M*N [R]
!              RWorkspace: need   0
!
               DO i = 1 , M , ldwrkr
                  chunk = MIN(M-i+1,ldwrkr)
                  CALL CGEMM('N','N',chunk,N,N,CONE,A(i,1),Lda,Work(iu),&
     &                       ldwrku,CZERO,Work(ir),ldwrkr)
                  CALL CLACPY('F',chunk,N,Work(ir),ldwrkr,A(i,1),Lda)
               ENDDO
!
            ELSEIF ( wntqs ) THEN
!
!              Path 3 (M >> N, JOBZ='S')
!              N left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
               ir = 1
!
!              WORK(IR) is N by N
!
               ldwrkr = N
               itau = ir + ldwrkr*N
               nwork = itau + N
!
!              Compute A=Q*R
!              CWorkspace: need   N*N [R] + N [tau] + N    [work]
!              CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CGEQRF(M,N,A,Lda,Work(itau),Work(nwork),            &
     &                     Lwork-nwork+1,ierr)
!
!              Copy R to WORK(IR), zeroing out below it
!
               CALL CLACPY('U',N,N,A,Lda,Work(ir),ldwrkr)
               CALL CLASET('L',N-1,N-1,CZERO,CZERO,Work(ir+1),ldwrkr)
!
!              Generate Q in A
!              CWorkspace: need   N*N [R] + N [tau] + N    [work]
!              CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CUNGQR(M,N,N,A,Lda,Work(itau),Work(nwork),          &
     &                     Lwork-nwork+1,ierr)
               ie = 1
               itauq = itau
               itaup = itauq + N
               nwork = itaup + N
!
!              Bidiagonalize R in WORK(IR)
!              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N      [work]
!              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
!              RWorkspace: need   N [e]
!
               CALL CGEBRD(N,N,Work(ir),ldwrkr,S,Rwork(ie),Work(itauq), &
     &                     Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = ie + N
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of R
!              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(iru),N,U,Ldu)
               CALL CUNMBR('Q','L','N',N,N,N,Work(ir),ldwrkr,Work(itauq)&
     &                     ,U,Ldu,Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of R
!              CWorkspace: need   N*N [R] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,Work(ir),ldwrkr,Work(itaup)&
     &                     ,Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IR), storing result in U
!              CWorkspace: need   N*N [R]
!              RWorkspace: need   0
!
               CALL CLACPY('F',N,N,U,Ldu,Work(ir),ldwrkr)
               CALL CGEMM('N','N',M,N,N,CONE,A,Lda,Work(ir),ldwrkr,     &
     &                    CZERO,U,Ldu)
!
            ELSEIF ( wntqa ) THEN
!
!              Path 4 (M >> N, JOBZ='A')
!              M left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
               iu = 1
!
!              WORK(IU) is N by N
!
               ldwrku = N
               itau = iu + ldwrku*N
               nwork = itau + N
!
!              Compute A=Q*R, copying result to U
!              CWorkspace: need   N*N [U] + N [tau] + N    [work]
!              CWorkspace: prefer N*N [U] + N [tau] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CGEQRF(M,N,A,Lda,Work(itau),Work(nwork),            &
     &                     Lwork-nwork+1,ierr)
               CALL CLACPY('L',M,N,A,Lda,U,Ldu)
!
!              Generate Q in U
!              CWorkspace: need   N*N [U] + N [tau] + M    [work]
!              CWorkspace: prefer N*N [U] + N [tau] + M*NB [work]
!              RWorkspace: need   0
!
               CALL CUNGQR(M,M,N,U,Ldu,Work(itau),Work(nwork),          &
     &                     Lwork-nwork+1,ierr)
!
!              Produce R in A, zeroing out below it
!
               CALL CLASET('L',N-1,N-1,CZERO,CZERO,A(2,1),Lda)
               ie = 1
               itauq = itau
               itaup = itauq + N
               nwork = itaup + N
!
!              Bidiagonalize R in A
!              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N      [work]
!              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + 2*N*NB [work]
!              RWorkspace: need   N [e]
!
               CALL CGEBRD(N,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup)&
     &                     ,Work(nwork),Lwork-nwork+1,ierr)
               iru = ie + N
               irvt = iru + N*N
               nrwork = irvt + N*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
!              Overwrite WORK(IU) by left singular vectors of R
!              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(iru),N,Work(iu),ldwrku)
               CALL CUNMBR('Q','L','N',N,N,N,A,Lda,Work(itauq),Work(iu),&
     &                     ldwrku,Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of R
!              CWorkspace: need   N*N [U] + 2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply Q in U by left singular vectors of R in
!              WORK(IU), storing result in A
!              CWorkspace: need   N*N [U]
!              RWorkspace: need   0
!
               CALL CGEMM('N','N',M,N,N,CONE,U,Ldu,Work(iu),ldwrku,     &
     &                    CZERO,A,Lda)
!
!              Copy left singular vectors of A from A to U
!
               CALL CLACPY('F',M,N,A,Lda,U,Ldu)
!
            ENDIF
!
         ELSEIF ( M>=mnthr2 ) THEN
!
!           MNTHR2 <= M < MNTHR1
!
!           Path 5 (M >> N, but not as much as MNTHR1)
!           Reduce to bidiagonal form without QR decomposition, use
!           CUNGBR and matrix multiplication to compute singular vectors
!
            ie = 1
            nrwork = ie + N
            itauq = 1
            itaup = itauq + N
            nwork = itaup + N
!
!           Bidiagonalize A
!           CWorkspace: need   2*N [tauq, taup] + M        [work]
!           CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
!           RWorkspace: need   N [e]
!
            CALL CGEBRD(M,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),  &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            IF ( wntqn ) THEN
!
!              Path 5n (M >> N, JOBZ='N')
!              Compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + BDSPAC
!
               CALL SBDSDC('U','N',N,S,Rwork(ie),dum,1,dum,1,dum,idum,  &
     &                     Rwork(nrwork),Iwork,Info)
            ELSEIF ( wntqo ) THEN
               iu = nwork
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
!
!              Path 5o (M >> N, JOBZ='O')
!              Copy A to VT, generate P**H
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACPY('U',N,N,A,Lda,Vt,Ldvt)
               CALL CUNGBR('P',N,N,N,Vt,Ldvt,Work(itaup),Work(nwork),   &
     &                     Lwork-nwork+1,ierr)
!
!              Generate Q in A
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CUNGBR('Q',M,N,N,A,Lda,Work(itauq),Work(nwork),     &
     &                     Lwork-nwork+1,ierr)
!
               IF ( Lwork>=M*N+3*N ) THEN
!
!                 WORK( IU ) is M by N
!
                  ldwrku = M
               ELSE
!
!                 WORK(IU) is LDWRKU by N
!
                  ldwrku = (Lwork-3*N)/N
               ENDIF
               nwork = iu + ldwrku*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Multiply real matrix RWORK(IRVT) by P**H in VT,
!              storing the result in WORK(IU), copying to VT
!              CWorkspace: need   2*N [tauq, taup] + N*N [U]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
!
               CALL CLARCM(N,N,Rwork(irvt),N,Vt,Ldvt,Work(iu),ldwrku,   &
     &                     Rwork(nrwork))
               CALL CLACPY('F',N,N,Work(iu),ldwrku,Vt,Ldvt)
!
!              Multiply Q in A by real matrix RWORK(IRU), storing the
!              result in WORK(IU), copying to A
!              CWorkspace: need   2*N [tauq, taup] + N*N [U]
!              CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
!              RWorkspace: need   N [e] + N*N [RU] + 2*N*N [rwork]
!              RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
!
               nrwork = irvt
               DO i = 1 , M , ldwrku
                  chunk = MIN(M-i+1,ldwrku)
                  CALL CLACRM(chunk,N,A(i,1),Lda,Rwork(iru),N,Work(iu), &
     &                        ldwrku,Rwork(nrwork))
                  CALL CLACPY('F',chunk,N,Work(iu),ldwrku,A(i,1),Lda)
               ENDDO
!
            ELSEIF ( wntqs ) THEN
!
!              Path 5s (M >> N, JOBZ='S')
!              Copy A to VT, generate P**H
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACPY('U',N,N,A,Lda,Vt,Ldvt)
               CALL CUNGBR('P',N,N,N,Vt,Ldvt,Work(itaup),Work(nwork),   &
     &                     Lwork-nwork+1,ierr)
!
!              Copy A to U, generate Q
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACPY('L',M,N,A,Lda,U,Ldu)
               CALL CUNGBR('Q',M,N,N,U,Ldu,Work(itauq),Work(nwork),     &
     &                     Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Multiply real matrix RWORK(IRVT) by P**H in VT,
!              storing the result in A, copying to VT
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
!
               CALL CLARCM(N,N,Rwork(irvt),N,Vt,Ldvt,A,Lda,Rwork(nrwork)&
     &                     )
               CALL CLACPY('F',N,N,A,Lda,Vt,Ldvt)
!
!              Multiply Q in U by real matrix RWORK(IRU), storing the
!              result in A, copying to U
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
!
               nrwork = irvt
               CALL CLACRM(M,N,U,Ldu,Rwork(iru),N,A,Lda,Rwork(nrwork))
               CALL CLACPY('F',M,N,A,Lda,U,Ldu)
            ELSE
!
!              Path 5a (M >> N, JOBZ='A')
!              Copy A to VT, generate P**H
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
               CALL CLACPY('U',N,N,A,Lda,Vt,Ldvt)
               CALL CUNGBR('P',N,N,N,Vt,Ldvt,Work(itaup),Work(nwork),   &
     &                     Lwork-nwork+1,ierr)
!
!              Copy A to U, generate Q
!              CWorkspace: need   2*N [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
               CALL CLACPY('L',M,N,A,Lda,U,Ldu)
               CALL CUNGBR('Q',M,M,N,U,Ldu,Work(itauq),Work(nwork),     &
     &                     Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Multiply real matrix RWORK(IRVT) by P**H in VT,
!              storing the result in A, copying to VT
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
!
               CALL CLARCM(N,N,Rwork(irvt),N,Vt,Ldvt,A,Lda,Rwork(nrwork)&
     &                     )
               CALL CLACPY('F',N,N,A,Lda,Vt,Ldvt)
!
!              Multiply Q in U by real matrix RWORK(IRU), storing the
!              result in A, copying to U
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
!
               nrwork = irvt
               CALL CLACRM(M,N,U,Ldu,Rwork(iru),N,A,Lda,Rwork(nrwork))
               CALL CLACPY('F',M,N,A,Lda,U,Ldu)
            ENDIF
!
         ELSE
!
!           M .LT. MNTHR2
!
!           Path 6 (M >= N, but not much larger)
!           Reduce to bidiagonal form without QR decomposition
!           Use CUNMBR to compute singular vectors
!
            ie = 1
            nrwork = ie + N
            itauq = 1
            itaup = itauq + N
            nwork = itaup + N
!
!           Bidiagonalize A
!           CWorkspace: need   2*N [tauq, taup] + M        [work]
!           CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
!           RWorkspace: need   N [e]
!
            CALL CGEBRD(M,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),  &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            IF ( wntqn ) THEN
!
!              Path 6n (M >= N, JOBZ='N')
!              Compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + BDSPAC
!
               CALL SBDSDC('U','N',N,S,Rwork(ie),dum,1,dum,1,dum,idum,  &
     &                     Rwork(nrwork),Iwork,Info)
            ELSEIF ( wntqo ) THEN
               iu = nwork
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
               IF ( Lwork>=M*N+3*N ) THEN
!
!                 WORK( IU ) is M by N
!
                  ldwrku = M
               ELSE
!
!                 WORK( IU ) is LDWRKU by N
!
                  ldwrku = (Lwork-3*N)/N
               ENDIF
               nwork = iu + ldwrku*N
!
!              Path 6o (M >= N, JOBZ='O')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of A
!              CWorkspace: need   2*N [tauq, taup] + N*N [U] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
!
               IF ( Lwork>=M*N+3*N ) THEN
!
!                 Path 6o-fast
!                 Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
!                 Overwrite WORK(IU) by left singular vectors of A, copying
!                 to A
!                 CWorkspace: need   2*N [tauq, taup] + M*N [U] + N    [work]
!                 CWorkspace: prefer 2*N [tauq, taup] + M*N [U] + N*NB [work]
!                 RWorkspace: need   N [e] + N*N [RU]
!
                  CALL CLASET('F',M,N,CZERO,CZERO,Work(iu),ldwrku)
                  CALL CLACP2('F',N,N,Rwork(iru),N,Work(iu),ldwrku)
                  CALL CUNMBR('Q','L','N',M,N,N,A,Lda,Work(itauq),      &
     &                        Work(iu),ldwrku,Work(nwork),Lwork-nwork+1,&
     &                        ierr)
                  CALL CLACPY('F',M,N,Work(iu),ldwrku,A,Lda)
               ELSE
!
!                 Path 6o-slow
!                 Generate Q in A
!                 CWorkspace: need   2*N [tauq, taup] + N*N [U] + N    [work]
!                 CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
!                 RWorkspace: need   0
!
                  CALL CUNGBR('Q',M,N,N,A,Lda,Work(itauq),Work(nwork),  &
     &                        Lwork-nwork+1,ierr)
!
!                 Multiply Q in A by real matrix RWORK(IRU), storing the
!                 result in WORK(IU), copying to A
!                 CWorkspace: need   2*N [tauq, taup] + N*N [U]
!                 CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
!                 RWorkspace: need   N [e] + N*N [RU] + 2*N*N [rwork]
!                 RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
!
                  nrwork = irvt
                  DO i = 1 , M , ldwrku
                     chunk = MIN(M-i+1,ldwrku)
                     CALL CLACRM(chunk,N,A(i,1),Lda,Rwork(iru),N,       &
     &                           Work(iu),ldwrku,Rwork(nrwork))
                     CALL CLACPY('F',chunk,N,Work(iu),ldwrku,A(i,1),Lda)
                  ENDDO
               ENDIF
!
            ELSEIF ( wntqs ) THEN
!
!              Path 6s (M >= N, JOBZ='S')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of A
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
!
               CALL CLASET('F',M,N,CZERO,CZERO,U,Ldu)
               CALL CLACP2('F',N,N,Rwork(iru),N,U,Ldu)
               CALL CUNMBR('Q','L','N',M,N,N,A,Lda,Work(itauq),U,Ldu,   &
     &                     Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of A
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
            ELSE
!
!              Path 6a (M >= N, JOBZ='A')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT] + BDSPAC
!
               iru = nrwork
               irvt = iru + N*N
               nrwork = irvt + N*N
               CALL SBDSDC('U','I',N,S,Rwork(ie),Rwork(iru),N,          &
     &                     Rwork(irvt),N,dum,idum,Rwork(nrwork),Iwork,  &
     &                     Info)
!
!              Set the right corner of U to identity matrix
!
               CALL CLASET('F',M,M,CZERO,CZERO,U,Ldu)
               IF ( M>N ) CALL CLASET('F',M-N,M-N,CZERO,CONE,U(N+1,N+1),&
     &                                Ldu)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of A
!              CWorkspace: need   2*N [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
!
               CALL CLACP2('F',N,N,Rwork(iru),N,U,Ldu)
               CALL CUNMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,   &
     &                     Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of A
!              CWorkspace: need   2*N [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
!              RWorkspace: need   N [e] + N*N [RU] + N*N [RVT]
!
               CALL CLACP2('F',N,N,Rwork(irvt),N,Vt,Ldvt)
               CALL CUNMBR('P','R','C',N,N,N,A,Lda,Work(itaup),Vt,Ldvt, &
     &                     Work(nwork),Lwork-nwork+1,ierr)
            ENDIF
!
         ENDIF
!
!
!        A has more columns than rows. If A has sufficiently more
!        columns than rows, first reduce using the LQ decomposition (if
!        sufficient workspace available)
!
      ELSEIF ( N>=mnthr1 ) THEN
!
         IF ( wntqn ) THEN
!
!              Path 1t (N >> M, JOBZ='N')
!              No singular vectors to be computed
!
            itau = 1
            nwork = itau + M
!
!              Compute A=L*Q
!              CWorkspace: need   M [tau] + M    [work]
!              CWorkspace: prefer M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Zero out above L
!
            CALL CLASET('U',M-1,M-1,CZERO,CZERO,A(1,2),Lda)
            ie = 1
            itauq = 1
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in A
!              CWorkspace: need   2*M [tauq, taup] + M      [work]
!              CWorkspace: prefer 2*M [tauq, taup] + 2*M*NB [work]
!              RWorkspace: need   M [e]
!
            CALL CGEBRD(M,M,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),  &
     &                  Work(nwork),Lwork-nwork+1,ierr)
            nrwork = ie + M
!
!              Perform bidiagonal SVD, compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + BDSPAC
!
            CALL SBDSDC('U','N',M,S,Rwork(ie),dum,1,dum,1,dum,idum,     &
     &                  Rwork(nrwork),Iwork,Info)
!
         ELSEIF ( wntqo ) THEN
!
!              Path 2t (N >> M, JOBZ='O')
!              M right singular vectors to be overwritten on A and
!              M left singular vectors to be computed in U
!
            ivt = 1
            ldwkvt = M
!
!              WORK(IVT) is M by M
!
            il = ivt + ldwkvt*M
            IF ( Lwork>=M*N+M*M+3*M ) THEN
!
!                 WORK(IL) M by N
!
               ldwrkl = M
               chunk = N
            ELSE
!
!                 WORK(IL) is M by CHUNK
!
               ldwrkl = M
               chunk = (Lwork-M*M-3*M)/M
            ENDIF
            itau = il + ldwrkl*chunk
            nwork = itau + M
!
!              Compute A=L*Q
!              CWorkspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
!              CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy L to WORK(IL), zeroing about above it
!
            CALL CLACPY('L',M,M,A,Lda,Work(il),ldwrkl)
            CALL CLASET('U',M-1,M-1,CZERO,CZERO,Work(il+ldwrkl),ldwrkl)
!
!              Generate Q in A
!              CWorkspace: need   M*M [VT] + M*M [L] + M [tau] + M    [work]
!              CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CUNGLQ(M,N,M,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = 1
            itauq = itau
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in WORK(IL)
!              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M      [work]
!              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
!              RWorkspace: need   M [e]
!
            CALL CGEBRD(M,M,Work(il),ldwrkl,S,Rwork(ie),Work(itauq),    &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
!
            iru = ie + M
            irvt = iru + M*M
            nrwork = irvt + M*M
            CALL SBDSDC('U','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
!              Overwrite WORK(IU) by the left singular vectors of L
!              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,M,Work(il),ldwrkl,Work(itauq),U,&
     &                  Ldu,Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
!              Overwrite WORK(IVT) by the right singular vectors of L
!              CWorkspace: need   M*M [VT] + M*M [L] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(irvt),M,Work(ivt),ldwkvt)
            CALL CUNMBR('P','R','C',M,M,M,Work(il),ldwrkl,Work(itaup),  &
     &                  Work(ivt),ldwkvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply right singular vectors of L in WORK(IL) by Q
!              in A, storing result in WORK(IL) and copying to A
!              CWorkspace: need   M*M [VT] + M*M [L]
!              CWorkspace: prefer M*M [VT] + M*N [L]
!              RWorkspace: need   0
!
            DO i = 1 , N , chunk
               blk = MIN(N-i+1,chunk)
               CALL CGEMM('N','N',M,blk,M,CONE,Work(ivt),M,A(1,i),Lda,  &
     &                    CZERO,Work(il),ldwrkl)
               CALL CLACPY('F',M,blk,Work(il),ldwrkl,A(1,i),Lda)
            ENDDO
!
         ELSEIF ( wntqs ) THEN
!
!              Path 3t (N >> M, JOBZ='S')
!              M right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
            il = 1
!
!              WORK(IL) is M by M
!
            ldwrkl = M
            itau = il + ldwrkl*M
            nwork = itau + M
!
!              Compute A=L*Q
!              CWorkspace: need   M*M [L] + M [tau] + M    [work]
!              CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
!
!              Copy L to WORK(IL), zeroing out above it
!
            CALL CLACPY('L',M,M,A,Lda,Work(il),ldwrkl)
            CALL CLASET('U',M-1,M-1,CZERO,CZERO,Work(il+ldwrkl),ldwrkl)
!
!              Generate Q in A
!              CWorkspace: need   M*M [L] + M [tau] + M    [work]
!              CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CUNGLQ(M,N,M,A,Lda,Work(itau),Work(nwork),             &
     &                  Lwork-nwork+1,ierr)
            ie = 1
            itauq = itau
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in WORK(IL)
!              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M      [work]
!              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
!              RWorkspace: need   M [e]
!
            CALL CGEBRD(M,M,Work(il),ldwrkl,S,Rwork(ie),Work(itauq),    &
     &                  Work(itaup),Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
!
            iru = ie + M
            irvt = iru + M*M
            nrwork = irvt + M*M
            CALL SBDSDC('U','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of L
!              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,M,Work(il),ldwrkl,Work(itauq),U,&
     &                  Ldu,Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by left singular vectors of L
!              CWorkspace: need   M*M [L] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(irvt),M,Vt,Ldvt)
            CALL CUNMBR('P','R','C',M,M,M,Work(il),ldwrkl,Work(itaup),  &
     &                  Vt,Ldvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy VT to WORK(IL), multiply right singular vectors of L
!              in WORK(IL) by Q in A, storing result in VT
!              CWorkspace: need   M*M [L]
!              RWorkspace: need   0
!
            CALL CLACPY('F',M,M,Vt,Ldvt,Work(il),ldwrkl)
            CALL CGEMM('N','N',M,N,M,CONE,Work(il),ldwrkl,A,Lda,CZERO,  &
     &                 Vt,Ldvt)
!
         ELSEIF ( wntqa ) THEN
!
!              Path 4t (N >> M, JOBZ='A')
!              N right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
            ivt = 1
!
!              WORK(IVT) is M by M
!
            ldwkvt = M
            itau = ivt + ldwkvt*M
            nwork = itau + M
!
!              Compute A=L*Q, copying result to VT
!              CWorkspace: need   M*M [VT] + M [tau] + M    [work]
!              CWorkspace: prefer M*M [VT] + M [tau] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CGELQF(M,N,A,Lda,Work(itau),Work(nwork),Lwork-nwork+1, &
     &                  ierr)
            CALL CLACPY('U',M,N,A,Lda,Vt,Ldvt)
!
!              Generate Q in VT
!              CWorkspace: need   M*M [VT] + M [tau] + N    [work]
!              CWorkspace: prefer M*M [VT] + M [tau] + N*NB [work]
!              RWorkspace: need   0
!
            CALL CUNGLQ(N,N,M,Vt,Ldvt,Work(itau),Work(nwork),           &
     &                  Lwork-nwork+1,ierr)
!
!              Produce L in A, zeroing out above it
!
            CALL CLASET('U',M-1,M-1,CZERO,CZERO,A(1,2),Lda)
            ie = 1
            itauq = itau
            itaup = itauq + M
            nwork = itaup + M
!
!              Bidiagonalize L in A
!              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M      [work]
!              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + 2*M*NB [work]
!              RWorkspace: need   M [e]
!
            CALL CGEBRD(M,M,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),  &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RU] + M*M [RVT] + BDSPAC
!
            iru = ie + M
            irvt = iru + M*M
            nrwork = irvt + M*M
            CALL SBDSDC('U','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of L
!              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,M,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
!              Overwrite WORK(IVT) by right singular vectors of L
!              CWorkspace: need   M*M [VT] + 2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACP2('F',M,M,Rwork(irvt),M,Work(ivt),ldwkvt)
            CALL CUNMBR('P','R','C',M,M,M,A,Lda,Work(itaup),Work(ivt),  &
     &                  ldwkvt,Work(nwork),Lwork-nwork+1,ierr)
!
!              Multiply right singular vectors of L in WORK(IVT) by
!              Q in VT, storing result in A
!              CWorkspace: need   M*M [VT]
!              RWorkspace: need   0
!
            CALL CGEMM('N','N',M,N,M,CONE,Work(ivt),ldwkvt,Vt,Ldvt,     &
     &                 CZERO,A,Lda)
!
!              Copy right singular vectors of A from A to VT
!
            CALL CLACPY('F',M,N,A,Lda,Vt,Ldvt)
!
         ENDIF
!
      ELSEIF ( N>=mnthr2 ) THEN
!
!           MNTHR2 <= N < MNTHR1
!
!           Path 5t (N >> M, but not as much as MNTHR1)
!           Reduce to bidiagonal form without QR decomposition, use
!           CUNGBR and matrix multiplication to compute singular vectors
!
         ie = 1
         nrwork = ie + M
         itauq = 1
         itaup = itauq + M
         nwork = itaup + M
!
!           Bidiagonalize A
!           CWorkspace: need   2*M [tauq, taup] + N        [work]
!           CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
!           RWorkspace: need   M [e]
!
         CALL CGEBRD(M,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),     &
     &               Work(nwork),Lwork-nwork+1,ierr)
!
         IF ( wntqn ) THEN
!
!              Path 5tn (N >> M, JOBZ='N')
!              Compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + BDSPAC
!
            CALL SBDSDC('L','N',M,S,Rwork(ie),dum,1,dum,1,dum,idum,     &
     &                  Rwork(nrwork),Iwork,Info)
         ELSEIF ( wntqo ) THEN
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
            ivt = nwork
!
!              Path 5to (N >> M, JOBZ='O')
!              Copy A to U, generate Q
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACPY('L',M,M,A,Lda,U,Ldu)
            CALL CUNGBR('Q',M,M,N,U,Ldu,Work(itauq),Work(nwork),        &
     &                  Lwork-nwork+1,ierr)
!
!              Generate P**H in A
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CUNGBR('P',M,N,M,A,Lda,Work(itaup),Work(nwork),        &
     &                  Lwork-nwork+1,ierr)
!
            ldwkvt = M
            IF ( Lwork>=M*N+3*M ) THEN
!
!                 WORK( IVT ) is M by N
!
               nwork = ivt + ldwkvt*N
               chunk = N
            ELSE
!
!                 WORK( IVT ) is M by CHUNK
!
               chunk = (Lwork-3*M)/M
               nwork = ivt + ldwkvt*chunk
            ENDIF
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Multiply Q in U by real matrix RWORK(IRVT)
!              storing the result in WORK(IVT), copying to U
!              CWorkspace: need   2*M [tauq, taup] + M*M [VT]
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
!
            CALL CLACRM(M,M,U,Ldu,Rwork(iru),M,Work(ivt),ldwkvt,        &
     &                  Rwork(nrwork))
            CALL CLACPY('F',M,M,Work(ivt),ldwkvt,U,Ldu)
!
!              Multiply RWORK(IRVT) by P**H in A, storing the
!              result in WORK(IVT), copying to A
!              CWorkspace: need   2*M [tauq, taup] + M*M [VT]
!              CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
!              RWorkspace: need   M [e] + M*M [RVT] + 2*M*M [rwork]
!              RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
!
            nrwork = iru
            DO i = 1 , N , chunk
               blk = MIN(N-i+1,chunk)
               CALL CLARCM(M,blk,Rwork(irvt),M,A(1,i),Lda,Work(ivt),    &
     &                     ldwkvt,Rwork(nrwork))
               CALL CLACPY('F',M,blk,Work(ivt),ldwkvt,A(1,i),Lda)
            ENDDO
         ELSEIF ( wntqs ) THEN
!
!              Path 5ts (N >> M, JOBZ='S')
!              Copy A to U, generate Q
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACPY('L',M,M,A,Lda,U,Ldu)
            CALL CUNGBR('Q',M,M,N,U,Ldu,Work(itauq),Work(nwork),        &
     &                  Lwork-nwork+1,ierr)
!
!              Copy A to VT, generate P**H
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACPY('U',M,N,A,Lda,Vt,Ldvt)
            CALL CUNGBR('P',M,N,M,Vt,Ldvt,Work(itaup),Work(nwork),      &
     &                  Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Multiply Q in U by real matrix RWORK(IRU), storing the
!              result in A, copying to U
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
!
            CALL CLACRM(M,M,U,Ldu,Rwork(iru),M,A,Lda,Rwork(nrwork))
            CALL CLACPY('F',M,M,A,Lda,U,Ldu)
!
!              Multiply real matrix RWORK(IRVT) by P**H in VT,
!              storing the result in A, copying to VT
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
!
            nrwork = iru
            CALL CLARCM(M,N,Rwork(irvt),M,Vt,Ldvt,A,Lda,Rwork(nrwork))
            CALL CLACPY('F',M,N,A,Lda,Vt,Ldvt)
         ELSE
!
!              Path 5ta (N >> M, JOBZ='A')
!              Copy A to U, generate Q
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   0
!
            CALL CLACPY('L',M,M,A,Lda,U,Ldu)
            CALL CUNGBR('Q',M,M,N,U,Ldu,Work(itauq),Work(nwork),        &
     &                  Lwork-nwork+1,ierr)
!
!              Copy A to VT, generate P**H
!              CWorkspace: need   2*M [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
!              RWorkspace: need   0
!
            CALL CLACPY('U',M,N,A,Lda,Vt,Ldvt)
            CALL CUNGBR('P',N,N,M,Vt,Ldvt,Work(itaup),Work(nwork),      &
     &                  Lwork-nwork+1,ierr)
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Multiply Q in U by real matrix RWORK(IRU), storing the
!              result in A, copying to U
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
!
            CALL CLACRM(M,M,U,Ldu,Rwork(iru),M,A,Lda,Rwork(nrwork))
            CALL CLACPY('F',M,M,A,Lda,U,Ldu)
!
!              Multiply real matrix RWORK(IRVT) by P**H in VT,
!              storing the result in A, copying to VT
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
!
            nrwork = iru
            CALL CLARCM(M,N,Rwork(irvt),M,Vt,Ldvt,A,Lda,Rwork(nrwork))
            CALL CLACPY('F',M,N,A,Lda,Vt,Ldvt)
         ENDIF
!
      ELSE
!
!           N .LT. MNTHR2
!
!           Path 6t (N > M, but not much larger)
!           Reduce to bidiagonal form without LQ decomposition
!           Use CUNMBR to compute singular vectors
!
         ie = 1
         nrwork = ie + M
         itauq = 1
         itaup = itauq + M
         nwork = itaup + M
!
!           Bidiagonalize A
!           CWorkspace: need   2*M [tauq, taup] + N        [work]
!           CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
!           RWorkspace: need   M [e]
!
         CALL CGEBRD(M,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),     &
     &               Work(nwork),Lwork-nwork+1,ierr)
         IF ( wntqn ) THEN
!
!              Path 6tn (N > M, JOBZ='N')
!              Compute singular values only
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + BDSPAC
!
            CALL SBDSDC('L','N',M,S,Rwork(ie),dum,1,dum,1,dum,idum,     &
     &                  Rwork(nrwork),Iwork,Info)
         ELSEIF ( wntqo ) THEN
!              Path 6to (N > M, JOBZ='O')
            ldwkvt = M
            ivt = nwork
            IF ( Lwork>=M*N+3*M ) THEN
!
!                 WORK( IVT ) is M by N
!
               CALL CLASET('F',M,N,CZERO,CZERO,Work(ivt),ldwkvt)
               nwork = ivt + ldwkvt*N
            ELSE
!
!                 WORK( IVT ) is M by CHUNK
!
               chunk = (Lwork-3*M)/M
               nwork = ivt + ldwkvt*chunk
            ENDIF
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of A
!              CWorkspace: need   2*M [tauq, taup] + M*M [VT] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
            IF ( Lwork>=M*N+3*M ) THEN
!
!                 Path 6to-fast
!                 Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
!                 Overwrite WORK(IVT) by right singular vectors of A,
!                 copying to A
!                 CWorkspace: need   2*M [tauq, taup] + M*N [VT] + M    [work]
!                 CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] + M*NB [work]
!                 RWorkspace: need   M [e] + M*M [RVT]
!
               CALL CLACP2('F',M,M,Rwork(irvt),M,Work(ivt),ldwkvt)
               CALL CUNMBR('P','R','C',M,N,M,A,Lda,Work(itaup),Work(ivt)&
     &                     ,ldwkvt,Work(nwork),Lwork-nwork+1,ierr)
               CALL CLACPY('F',M,N,Work(ivt),ldwkvt,A,Lda)
            ELSE
!
!                 Path 6to-slow
!                 Generate P**H in A
!                 CWorkspace: need   2*M [tauq, taup] + M*M [VT] + M    [work]
!                 CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
!                 RWorkspace: need   0
!
               CALL CUNGBR('P',M,N,M,A,Lda,Work(itaup),Work(nwork),     &
     &                     Lwork-nwork+1,ierr)
!
!                 Multiply Q in A by real matrix RWORK(IRU), storing the
!                 result in WORK(IU), copying to A
!                 CWorkspace: need   2*M [tauq, taup] + M*M [VT]
!                 CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
!                 RWorkspace: need   M [e] + M*M [RVT] + 2*M*M [rwork]
!                 RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
!
               nrwork = iru
               DO i = 1 , N , chunk
                  blk = MIN(N-i+1,chunk)
                  CALL CLARCM(M,blk,Rwork(irvt),M,A(1,i),Lda,Work(ivt), &
     &                        ldwkvt,Rwork(nrwork))
                  CALL CLACPY('F',M,blk,Work(ivt),ldwkvt,A(1,i),Lda)
               ENDDO
            ENDIF
         ELSEIF ( wntqs ) THEN
!
!              Path 6ts (N > M, JOBZ='S')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of A
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of A
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   M [e] + M*M [RVT]
!
            CALL CLASET('F',M,N,CZERO,CZERO,Vt,Ldvt)
            CALL CLACP2('F',M,M,Rwork(irvt),M,Vt,Ldvt)
            CALL CUNMBR('P','R','C',M,N,M,A,Lda,Work(itaup),Vt,Ldvt,    &
     &                  Work(nwork),Lwork-nwork+1,ierr)
         ELSE
!
!              Path 6ta (N > M, JOBZ='A')
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in RWORK(IRU) and computing right
!              singular vectors of bidiagonal matrix in RWORK(IRVT)
!              CWorkspace: need   0
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU] + BDSPAC
!
            irvt = nrwork
            iru = irvt + M*M
            nrwork = iru + M*M
!
            CALL SBDSDC('L','I',M,S,Rwork(ie),Rwork(iru),M,Rwork(irvt), &
     &                  M,dum,idum,Rwork(nrwork),Iwork,Info)
!
!              Copy real matrix RWORK(IRU) to complex matrix U
!              Overwrite U by left singular vectors of A
!              CWorkspace: need   2*M [tauq, taup] + M    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
!              RWorkspace: need   M [e] + M*M [RVT] + M*M [RU]
!
            CALL CLACP2('F',M,M,Rwork(iru),M,U,Ldu)
            CALL CUNMBR('Q','L','N',M,M,N,A,Lda,Work(itauq),U,Ldu,      &
     &                  Work(nwork),Lwork-nwork+1,ierr)
!
!              Set all of VT to identity matrix
!
            CALL CLASET('F',N,N,CZERO,CONE,Vt,Ldvt)
!
!              Copy real matrix RWORK(IRVT) to complex matrix VT
!              Overwrite VT by right singular vectors of A
!              CWorkspace: need   2*M [tauq, taup] + N    [work]
!              CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
!              RWorkspace: need   M [e] + M*M [RVT]
!
            CALL CLACP2('F',M,M,Rwork(irvt),M,Vt,Ldvt)
            CALL CUNMBR('P','R','C',N,N,M,A,Lda,Work(itaup),Vt,Ldvt,    &
     &                  Work(nwork),Lwork-nwork+1,ierr)
         ENDIF
!
!
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( iscl==1 ) THEN
         IF ( anrm>bignum ) CALL SLASCL('G',0,0,bignum,anrm,minmn,1,S,  &
     &                                  minmn,ierr)
         IF ( Info/=0 .AND. anrm>bignum )                               &
     &        CALL SLASCL('G',0,0,bignum,anrm,minmn-1,1,Rwork(ie),minmn,&
     &        ierr)
         IF ( anrm<smlnum ) CALL SLASCL('G',0,0,smlnum,anrm,minmn,1,S,  &
     &                                  minmn,ierr)
         IF ( Info/=0 .AND. anrm<smlnum )                               &
     &        CALL SLASCL('G',0,0,smlnum,anrm,minmn-1,1,Rwork(ie),minmn,&
     &        ierr)
      ENDIF
!
!     Return optimal workspace in WORK(1)
!
      Work(1) = maxwrk
!
!
!     End of CGESDD
!
      END SUBROUTINE CGESDD


************************************************************************
*
*     Subroutine CALCPI                               Called by: L1NORM
*
*     forward solve linear system.   Routine assumes NPAR > 1.
*
************************************************************************
      SUBROUTINE CALCPI(KKK,PI,TOT,NPAR,INDX,LU)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 KKK,NPAR,INDX(*)
      DOUBLE PRECISION PI(*),TOT(*),LU(MAXPARMS,*)
*
*     local vars
*
      INTEGER*4 I,II,K1,K2
*
*     initialize PI
*
      DO 10 I=1,KKK
         PI(I) = 0.D0
   10 CONTINUE

      KKK = KKK + 1
      PI(KKK) = TOT(INDX(KKK))

      DO 30 II=KKK+1,NPAR
         PI(II) = TOT(INDX(II))
         DO 20 I=KKK,II-1
            PI(II) = PI(II)-LU(INDX(II),I)*PI(I)
 20      CONTINUE
 30   CONTINUE

      PI(NPAR) = PI(NPAR)/LU(INDX(NPAR),NPAR)

      DO 50 II=1,NPAR-1
         K1 = NPAR-II

         DO 40 I=1,II
            K2 = NPAR-I+1
            PI(K1) = PI(K1)-LU(INDX(K1),K2)*PI(K2)
 40      CONTINUE
         PI(K1) = PI(K1)/LU(INDX(K1),K1)
 50   CONTINUE

      RETURN
      END


      double precision function dnrm2(n,x,incx)
      integer n,incx
      double precision x(n)
c     **********
c
c     Function dnrm2
c
c     Given a vector x of length n, this function calculates the
c     Euclidean norm of x with stride incx.
c
c     The function statement is
c
c       double precision function dnrm2(n,x,incx)
c
c     where
c
c       n is a positive integer input variable.
c
c       x is an input array of length n.
c
c       incx is a positive integer variable that specifies the
c         stride of the vector.
c
c     Subprograms called
c
c       FORTRAN-supplied ... abs, max, sqrt
c
c     MINPACK-2 Project. February 1991.
c     Argonne National Laboratory.
c     Brett M. Averick.
c
c     **********
      integer i
      double precision scale

      dnrm2 = 0.0d0
      scale = 0.0d0

      do 10 i = 1, n, incx
         scale = max(scale, abs(x(i)))
   10 continue

      if (scale .eq. 0.0d0) return

      do 20 i = 1, n, incx
         dnrm2 = dnrm2 + (x(i)/scale)**2
   20 continue

      dnrm2 = scale*sqrt(dnrm2)

      return

      end

c====================== The end of dnrm2 ===============================

      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end

c====================== The end of daxpy ===============================

      subroutine dcopy(n,dx,incx,dy,incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end

c====================== The end of dcopy ===============================

      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end

c====================== The end of ddot ================================

      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end

c====================== The end of dscal ===============================


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! complex type bound function call

module mmm
  complex, parameter :: bits(3) = [(1.0,2.0), (-3.0,-4.0), (5.0,6.0)]
  type :: vector
    complex :: data(3) = bits
  contains
    procedure :: get_value
  end type vector

contains
  complex function get_value(vec, elem)
    class(vector) :: vec
    integer       :: elem
    get_value = vec%data(elem)
  end function get_value
end

program test
  use mmm
  type(vector) :: vec
  integer      :: elem
  complex      :: ccc(3)
  do elem = 1, 3
    ccc(elem) = vec%get_value(elem)
  end do
  print*, sum(ccc), sum(bits)
  if (sum(ccc) .eq. sum(bits)) print*, 'PASS'
  if (sum(ccc) .ne. sum(bits)) print*, 'FAIL'
end


! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/38282
!
implicit none
integer :: a(2,1)

a(1,1) = 35
a(2,1) = -74

if (iand(a(1,1),a(2,1)) /= iall(a)) stop 1 ! { dg-error " .iall. at .1. has no IMPLICIT type" }

if (ior(a(1,1),a(2,1)) /= iany(a)) stop 1 ! { dg-error " .iany. at .1. has no IMPLICIT type" }

if (ieor(a(1,1),a(2,1)) /= iparity(a)) stop 1 ! { dg-error " .iparity. at .1. has no IMPLICIT type" }

end


* FORTRAN test file to implement the DATA statement
* This file uses the DATA statement to assign arrays

**********************************************************************
* Expected Output:  X: 2
*
*                   VEC:
*                   3.0
*                   4.0
*                   5.0
*
*                   Y: 6  Z: 6
*
*                   PAIR1:
*                   7.0
*                   8.0
*
*                   HELLO!
**********************************************************************

      PROGRAM MAIN

      IMPLICIT NONE

      REAL, DIMENSION(3) :: VEC
      REAL, DIMENSION(2) :: PAIR1
      INTEGER :: X,Y,Z
      CHARACTER A*6

      INTEGER :: I

      DATA X,VEC,Y,Z,PAIR1,A /2,3,4,5,2*6,7,8,'HELLO!'/

      WRITE(*,50) 'X: ', X

      WRITE (*,11)
      WRITE (*,12) 'VEC: '
      DO I = 1, 3
          WRITE (*,10) VEC(I)
      END DO

      WRITE (*,11)
      WRITE(*,60) 'Y: ', Y, 'Z: ', Z

      WRITE (*,11)
      WRITE (*,12) 'PAIR1: '
      DO I = 1, 2
          WRITE(*,10) PAIR1(I)
      END DO

      WRITE (*,11)
      WRITE(*,12) A

 10   FORMAT(F3.1)
 11   FORMAT('')
 12   FORMAT(A)
 20   FORMAT(4(F3.1,2X))
 30   FORMAT(3(I1,2X))
 50   FORMAT(A, I1)
 60   FORMAT(A, I1, 2X, A, I1)

      END PROGRAM MAIN


      SUBROUTINE ZPTTRSV( UPLO, TRANS, N, NRHS, D, E, B, LDB,
     $                        INFO )
*
*  -- ScaLAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*
*     Written by Andrew J. Cleary, University of Tennessee.
*     November, 1996.
*     Modified from ZPTTRS:
*  -- LAPACK routine (preliminary version) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO, TRANS
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * )
      COMPLEX*16         B( LDB, * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  ZPTTRSV solves one of the triangular systems
*     L * X = B, or  L**H * X = B,
*     U * X = B, or  U**H * X = B,
*  where L or U is the Cholesky factor of a Hermitian positive
*  definite tridiagonal matrix A such that
*  A = U**H*D*U or A = L*D*L**H (computed by ZPTTRF).
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the superdiagonal or the subdiagonal
*          of the tridiagonal matrix A is stored and the form of the
*          factorization:
*          = 'U':  E is the superdiagonal of U, and A = U'*D*U;
*          = 'L':  E is the subdiagonal of L, and A = L*D*L'.
*          (The two forms are equivalent if A is real.)
*
*  TRANS   (input) CHARACTER
*          Specifies the form of the system of equations:
*          = 'N':  L * X = B     (No transpose)
*          = 'N':  L * X = B     (No transpose)
*          = 'C':  U**H * X = B  (Conjugate transpose)
*          = 'C':  L**H * X = B  (Conjugate transpose)
*
*  N       (input) INTEGER
*          The order of the tridiagonal matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  D       (input) REAL array, dimension (N)
*          The n diagonal elements of the diagonal matrix D from the
*          factorization computed by ZPTTRF.
*
*  E       (input) COMPLEX array, dimension (N-1)
*          The (n-1) off-diagonal elements of the unit bidiagonal
*          factor U or L from the factorization computed by ZPTTRF
*          (see UPLO).
*
*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            NOTRAN, UPPER
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPTTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
      IF( .NOT.NOTRAN ) THEN
*
         DO 30 J = 1, NRHS
*
*           Solve U**T (or H) * x = b.
*
            DO 10 I = 2, N
               B( I, J ) = B( I, J ) - B( I-1, J )*DCONJG( E( I-1 ) )
   10       CONTINUE
   30    CONTINUE
*
      ELSE
*
         DO 35 J = 1, NRHS
*
*           Solve U * x = b.
*
            DO 20 I = N - 1, 1, -1
               B( I, J ) = B( I, J ) - B( I+1, J )*E( I )
   20       CONTINUE
   35    CONTINUE
      ENDIF
*
      ELSE
*
      IF( NOTRAN ) THEN
*
         DO 60 J = 1, NRHS
*
*           Solve L * x = b.
*
            DO 40 I = 2, N
               B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
   40       CONTINUE
   60    CONTINUE
*
      ELSE
*
         DO 65 J = 1, NRHS
*
*           Solve L**H * x = b.
*
            DO 50 I = N - 1, 1, -1
               B( I, J ) = B( I, J ) -
     $                     B( I+1, J )*DCONJG( E( I ) )
   50       CONTINUE
   65    CONTINUE
      ENDIF
*
      END IF
*
      RETURN
*
*     End of ZPTTRS
*
      END