zgesdd.f

计算矩阵的经典开源库．全世界都在用它．相信你也不能例外．

     $                     ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*N+N*
     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) )
                  MAXWRK = MAXWRK + M*N
                  MINWRK = MINWRK + N*N
               ELSE IF( WNTQS ) THEN
                  MAXWRK = MAX( MAXWRK, 2*N+N*
     $                     ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*N+N*
     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) )
               ELSE IF( WNTQA ) THEN
                  MAXWRK = MAX( MAXWRK, 2*N+N*
     $                     ILAENV( 1, 'ZUNGBR', 'PRC', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*N+M*
     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
               END IF
            END IF
         ELSE
*
*           There is no complex work space needed for bidiagonal SVD
*           The real work space needed for bidiagonal SVD is BDSPAC,
*           BDSPAC = 3*M*M + 4*M
*
            IF( N.GE.MNTHR1 ) THEN
               IF( WNTQN ) THEN
*
*                 Path 1t (N much larger than M, JOBZ='N')
*
                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
     $                     -1 )
                  MAXWRK = MAX( MAXWRK, 2*M+2*M*
     $                     ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  MINWRK = 3*M
               ELSE IF( WNTQO ) THEN
*
*                 Path 2t (N much larger than M, JOBZ='O')
*
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
                  MAXWRK = M*N + M*M + WRKBL
                  MINWRK = 2*M*M + 3*M
               ELSE IF( WNTQS ) THEN
*
*                 Path 3t (N much larger than M, JOBZ='S')
*
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = M*M + 3*M
               ELSE IF( WNTQA ) THEN
*
*                 Path 4t (N much larger than M, JOBZ='A')
*
                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
     $                    N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+2*M*
     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 2*M+M*
     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
                  MAXWRK = M*M + WRKBL
                  MINWRK = M*M + 2*M + N
               END IF
            ELSE IF( N.GE.MNTHR2 ) THEN
*
*              Path 5t (N much larger than M, but not as much as MNTHR1)
*
               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
     $                  -1, -1 )
               MINWRK = 2*M + N
               IF( WNTQO ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
                  MAXWRK = MAXWRK + M*N
                  MINWRK = MINWRK + M*M
               ELSE IF( WNTQS ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
               ELSE IF( WNTQA ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+N*
     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
               END IF
            ELSE
*
*              Path 6t (N greater than M, but not much larger)
*
               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
     $                  -1, -1 )
               MINWRK = 2*M + N
               IF( WNTQO ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNMBR', 'PRC', M, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, M, N, -1 ) )
                  MAXWRK = MAXWRK + M*N
                  MINWRK = MINWRK + M*M
               ELSE IF( WNTQS ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'PRC', M, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
               ELSE IF( WNTQA ) THEN
                  MAXWRK = MAX( MAXWRK, 2*M+N*
     $                     ILAENV( 1, 'ZUNGBR', 'PRC', N, N, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, 2*M+M*
     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
               END IF
            END IF
         END IF
         MAXWRK = MAX( MAXWRK, MINWRK )
         WORK( 1 ) = MAXWRK
      END IF
*
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGESDD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         IF( LWORK.GE.1 )
     $      WORK( 1 ) = ONE
         RETURN
      END IF
*
*     Get machine constants
*
      EPS = DLAMCH( 'P' )
      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         OPS = OPS + DBLE( 6*M*N )
         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         OPS = OPS + DBLE( 6*M*N )
         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
      END IF
*
      IF( M.GE.N ) THEN
*
*        A has at least as many rows as columns. If A has sufficiently
*        more rows than columns, first reduce using the QR
*        decomposition (if sufficient workspace available)
*
         IF( M.GE.MNTHR1 ) THEN
*
            IF( WNTQN ) THEN
*
*              Path 1 (M much larger than N, JOBZ='N')
*              No singular vectors to be computed
*
               ITAU = 1
               NWORK = ITAU + N
*
*              Compute A=Q*R
*              (CWorkspace: need 2*N, prefer N+N*NB)
*              (RWorkspace: need 0)
*
               NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
               OPS = OPS + DOPLA( 'ZGEQRF', M, N, 0, 0, NB )
               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
     $                      LWORK-NWORK+1, IERR )
*
*              Zero out below R
*
               CALL ZLASET( '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 3*N, prefer 2*N+2*N*NB)
*              (RWorkspace: need N)
*
               NB = ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 )
               OPS = OPS + DOPLA( 'ZGEBRD', N, N, 0, 0, NB )
               CALL ZGEBRD( 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: 0)
*              (RWorkspace: need BDSPAC)
*
               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
*
            ELSE IF( WNTQO ) THEN
*
*              Path 2 (M much larger than 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.GE.M*N+N*N+3*N ) THEN
*
*                 WORK(IR) is M by N
*
                  LDWRKR = M
               ELSE
                  LDWRKR = ( LWORK-N*N-3*N ) / N
               END IF
               ITAU = IR + LDWRKR*N
               NWORK = ITAU + N
*
*              Compute A=Q*R
*              (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB)
*              (RWorkspace: 0)
*
               NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
               OPS = OPS + DOPLA( 'ZGEQRF', M, N, 0, 0, NB )
               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
     $                      LWORK-NWORK+1, IERR )
*
*              Copy R to WORK( IR ), zeroing out below it
*
               CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, WORK( IR+1 ),
     $                      LDWRKR )
*
*              Generate Q in A
*              (CWorkspace: need 2*N, prefer N+N*NB)
*              (RWorkspace: 0)
*
               NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, N, -1 )
               OPS = OPS + DOPLA( 'ZUNGQR', M, N, N, 0, NB )
               CALL ZUNGQR( 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+3*N, prefer M*N+2*N+2*N*NB)
*              (RWorkspace: need N)
*
               NB = ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 )
               OPS = OPS + DOPLA( 'ZGEBRD', N, N, 0, 0, NB )
               CALL ZGEBRD( 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 BDSPAC)
*
               IRU = IE + N
               IRVT = IRU + N*N
               NRWORK = IRVT + N*N
               CALL DBDSDC( '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 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB)
*              (RWorkspace: 0)
*
               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
     $                      LDWRKU )
               NB = ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 )
               OPS = OPS + DOPLA2( 'ZUNMBR', 'QLN', N, N, N, 0, NB )
               CALL ZUNMBR( '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+3*N, prefer M*N+2*N+N*NB)
*              (RWorkspace: 0)
*
               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
               NB = ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 )
               OPS = OPS + DOPLA2( 'ZUNMBR', 'PRC', N, N, N, 0, NB )
               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
     $                      LWORK-NWORK+1, IERR )
*