*> \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DZSUM1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DZSUM1 takes the sum of the absolute values of a complex
*> vector and returns a double precision result.
*>
*> Based on DZASUM from the Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vector CX.
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> The vector whose elements will be summed.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive values of CX. INCX > 0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, NINCX
DOUBLE PRECISION STEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
DZSUM1 = 0.0D0
STEMP = 0.0D0
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 )
$ GO TO 20
*
* CODE FOR INCREMENT NOT EQUAL TO 1
*
NINCX = N*INCX
DO 10 I = 1, NINCX, INCX
*
* NEXT LINE MODIFIED.
*
STEMP = STEMP + ABS( CX( I ) )
10 CONTINUE
DZSUM1 = STEMP
RETURN
*
* CODE FOR INCREMENT EQUAL TO 1
*
20 CONTINUE
DO 30 I = 1, N
*
* NEXT LINE MODIFIED.
*
STEMP = STEMP + ABS( CX( I ) )
30 CONTINUE
DZSUM1 = STEMP
RETURN
*
* End of DZSUM1
*
END
*> \brief \b ILAZLC scans a matrix for its last non-zero column.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILAZLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILAZLC = N, 1, -1
DO I = 1, M
IF( A(I, ILAZLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
*> \brief \b ILAZLR scans a matrix for its last non-zero row.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILAZLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILAZLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILAZLR = MAX( ILAZLR, I )
END DO
END IF
RETURN
END
*> \brief \b IZMAX1 finds the index of the vector element whose real part has maximum absolute value.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IZMAX1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IZMAX1( N, CX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IZMAX1 finds the index of the element whose real part has maximum
*> absolute value.
*>
*> Based on IZAMAX from Level 1 BLAS.
*> The change is to use the 'genuine' absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vector CX.
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> The vector whose elements will be summed.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive values of CX. INCX >= 1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
INTEGER FUNCTION IZMAX1( N, CX, INCX )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX
DOUBLE PRECISION SMAX
COMPLEX*16 ZDUM
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
*
* NEXT LINE IS THE ONLY MODIFICATION.
CABS1( ZDUM ) = ABS( ZDUM )
* ..
* .. Executable Statements ..
*
IZMAX1 = 0
IF( N.LT.1 )
$ RETURN
IZMAX1 = 1
IF( N.EQ.1 )
$ RETURN
IF( INCX.EQ.1 )
$ GO TO 30
*
* CODE FOR INCREMENT NOT EQUAL TO 1
*
IX = 1
SMAX = CABS1( CX( 1 ) )
IX = IX + INCX
DO 20 I = 2, N
IF( CABS1( CX( IX ) ).LE.SMAX )
$ GO TO 10
IZMAX1 = I
SMAX = CABS1( CX( IX ) )
10 CONTINUE
IX = IX + INCX
20 CONTINUE
RETURN
*
* CODE FOR INCREMENT EQUAL TO 1
*
30 CONTINUE
SMAX = CABS1( CX( 1 ) )
DO 40 I = 2, N
IF( CABS1( CX( I ) ).LE.SMAX )
$ GO TO 40
IZMAX1 = I
SMAX = CABS1( CX( I ) )
40 CONTINUE
RETURN
*
* End of IZMAX1
*
END
*> \brief \b ZBDSQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZBDSQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
* LDU, C, LDC, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZBDSQR computes the singular values and, optionally, the right and/or
*> left singular vectors from the singular value decomposition (SVD) of
*> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
*> zero-shift QR algorithm. The SVD of B has the form
*>
*> B = Q * S * P**H
*>
*> where S is the diagonal matrix of singular values, Q is an orthogonal
*> matrix of left singular vectors, and P is an orthogonal matrix of
*> right singular vectors. If left singular vectors are requested, this
*> subroutine actually returns U*Q instead of Q, and, if right singular
*> vectors are requested, this subroutine returns P**H*VT instead of
*> P**H, for given complex input matrices U and VT. When U and VT are
*> the unitary matrices that reduce a general matrix A to bidiagonal
*> form: A = U*B*VT, as computed by ZGEBRD, then
*>
*> A = (U*Q) * S * (P**H*VT)
*>
*> is the SVD of A. Optionally, the subroutine may also compute Q**H*C
*> for a given complex input matrix C.
*>
*> See "Computing Small Singular Values of Bidiagonal Matrices With
*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
*> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
*> no. 5, pp. 873-912, Sept 1990) and
*> "Accurate singular values and differential qd algorithms," by
*> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
*> Department, University of California at Berkeley, July 1992
*> for a detailed description of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': B is upper bidiagonal;
*> = 'L': B is lower bidiagonal.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix B. N >= 0.
*> \endverbatim
*>
*> \param[in] NCVT
*> \verbatim
*> NCVT is INTEGER
*> The number of columns of the matrix VT. NCVT >= 0.
*> \endverbatim
*>
*> \param[in] NRU
*> \verbatim
*> NRU is INTEGER
*> The number of rows of the matrix U. NRU >= 0.
*> \endverbatim
*>
*> \param[in] NCC
*> \verbatim
*> NCC is INTEGER
*> The number of columns of the matrix C. NCC >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the n diagonal elements of the bidiagonal matrix B.
*> On exit, if INFO=0, the singular values of B in decreasing
*> order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the N-1 offdiagonal elements of the bidiagonal
*> matrix B.
*> On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
*> will contain the diagonal and superdiagonal elements of a
*> bidiagonal matrix orthogonally equivalent to the one given
*> as input.
*> \endverbatim
*>
*> \param[in,out] VT
*> \verbatim
*> VT is COMPLEX*16 array, dimension (LDVT, NCVT)
*> On entry, an N-by-NCVT matrix VT.
*> On exit, VT is overwritten by P**H * VT.
*> Not referenced if NCVT = 0.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*> LDVT is INTEGER
*> The leading dimension of the array VT.
*> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*> \endverbatim
*>
*> \param[in,out] U
*> \verbatim
*> U is COMPLEX*16 array, dimension (LDU, N)
*> On entry, an NRU-by-N matrix U.
*> On exit, U is overwritten by U * Q.
*> Not referenced if NRU = 0.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> The leading dimension of the array U. LDU >= max(1,NRU).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, NCC)
*> On entry, an N-by-NCC matrix C.
*> On exit, C is overwritten by Q**H * C.
*> Not referenced if NCC = 0.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C.
*> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*N)
*> if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise
*> \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 algorithm did not converge; D and E contain the
*> elements of a bidiagonal matrix which is orthogonally
*> similar to the input matrix B; if INFO = i, i
*> elements of E have not converged to zero.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
*> TOLMUL controls the convergence criterion of the QR loop.
*> If it is positive, TOLMUL*EPS is the desired relative
*> precision in the computed singular values.
*> If it is negative, abs(TOLMUL*EPS*sigma_max) is the
*> desired absolute accuracy in the computed singular
*> values (corresponds to relative accuracy
*> abs(TOLMUL*EPS) in the largest singular value.
*> abs(TOLMUL) should be between 1 and 1/EPS, and preferably
*> between 10 (for fast convergence) and .1/EPS
*> (for there to be some accuracy in the results).
*> Default is to lose at either one eighth or 2 of the
*> available decimal digits in each computed singular value
*> (whichever is smaller).
*>
*> MAXITR INTEGER, default = 6
*> MAXITR controls the maximum number of passes of the
*> algorithm through its inner loop. The algorithms stops
*> (and so fails to converge) if the number of passes
*> through the inner loop exceeds MAXITR*N**2.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, RWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
DOUBLE PRECISION HNDRTH
PARAMETER ( HNDRTH = 0.01D0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 10.0D0 )
DOUBLE PRECISION HNDRD
PARAMETER ( HNDRD = 100.0D0 )
DOUBLE PRECISION MEIGTH
PARAMETER ( MEIGTH = -0.125D0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT,
$ ZDSCAL, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL DLASQ1( N, D, E, RWORK, INFO )
*
* If INFO equals 2, dqds didn't finish, try to finish
*
IF( INFO .NE. 2 ) RETURN
INFO = 0
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
RWORK( I ) = CS
RWORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
$ U, LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ),
$ C, LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( DBLE( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
$ COSR, SINR )
IF( NRU.GT.0 )
$ CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
RWORK( I-LL+1 ) = CS
RWORK( I-LL+1+NM1 ) = SN
RWORK( I-LL+1+NM12 ) = OLDCS
RWORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
$ RWORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
RWORK( I-LL ) = CS
RWORK( I-LL+NM1 ) = -SN
RWORK( I-LL+NM12 ) = OLDCS
RWORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
$ RWORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
$ RWORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
RWORK( I-LL+1 ) = COSR
RWORK( I-LL+1+NM1 ) = SINR
RWORK( I-LL+1+NM12 ) = COSL
RWORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
$ RWORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
RWORK( I-LL ) = COSR
RWORK( I-LL+NM1 ) = -SINR
RWORK( I-LL+NM12 ) = COSL
RWORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
$ RWORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
$ RWORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of ZBDSQR
*
END
*> \brief \b ZDRSCL multiplies a vector by the reciprocal of a real scalar.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZDRSCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZDRSCL( N, SA, SX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION SA
* ..
* .. Array Arguments ..
* COMPLEX*16 SX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZDRSCL multiplies an n-element complex vector x by the real scalar
*> 1/a. This is done without overflow or underflow as long as
*> the final result x/a does not overflow or underflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of components of the vector x.
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is DOUBLE PRECISION
*> The scalar a which is used to divide each component of x.
*> SA must be >= 0, or the subroutine will divide by zero.
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is COMPLEX*16 array, dimension
*> (1+(N-1)*abs(INCX))
*> The n-element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of the vector SX.
*> > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZDRSCL( N, SA, SX, INCX )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SA
* ..
* .. Array Arguments ..
COMPLEX*16 SX( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZDSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Initialize the denominator to SA and the numerator to 1.
*
CDEN = SA
CNUM = ONE
*
10 CONTINUE
CDEN1 = CDEN*SMLNUM
CNUM1 = CNUM / BIGNUM
IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
MUL = SMLNUM
DONE = .FALSE.
CDEN = CDEN1
ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
MUL = BIGNUM
DONE = .FALSE.
CNUM = CNUM1
ELSE
*
* Multiply X by CNUM / CDEN and return.
*
MUL = CNUM / CDEN
DONE = .TRUE.
END IF
*
* Scale the vector X by MUL
*
CALL ZDSCAL( N, MUL, SX, INCX )
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of ZDRSCL
*
END
*> \brief \b ZGEBAK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAK + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB, SIDE
* INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION SCALE( * )
* COMPLEX*16 V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBAK forms the right or left eigenvectors of a complex general
*> matrix by backward transformation on the computed eigenvectors of the
*> balanced matrix output by ZGEBAL.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies the type of backward transformation required:
*> = 'N', do nothing, return immediately;
*> = 'P', do backward transformation for permutation only;
*> = 'S', do backward transformation for scaling only;
*> = 'B', do backward transformations for both permutation and
*> scaling.
*> JOB must be the same as the argument JOB supplied to ZGEBAL.
*> \endverbatim
*>
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'R': V contains right eigenvectors;
*> = 'L': V contains left eigenvectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows of the matrix V. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> The integers ILO and IHI determined by ZGEBAL.
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutation and scaling factors, as returned
*> by ZGEBAL.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of columns of the matrix V. M >= 0.
*> \endverbatim
*>
*> \param[in,out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,M)
*> On entry, the matrix of right or left eigenvectors to be
*> transformed, as returned by ZHSEIN or ZTREVC.
*> On exit, V is overwritten by the transformed eigenvectors.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V. LDV >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SCALE( * )
COMPLEX*16 V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, II, K
DOUBLE PRECISION S
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
S = SCALE( I )
CALL ZDSCAL( M, S, V( I, 1 ), LDV )
10 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
S = ONE / SCALE( I )
CALL ZDSCAL( M, S, V( I, 1 ), LDV )
20 CONTINUE
END IF
*
END IF
*
* Backward permutation
*
* For I = ILO-1 step -1 until 1,
* IHI+1 step 1 until N do --
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
IF( RIGHTV ) THEN
DO 40 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 40
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 50 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 50
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 50
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
50 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZGEBAK
*
END
*> \brief \b ZGEBAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB
* INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION SCALE( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBAL balances a general complex matrix A. This involves, first,
*> permuting A by a similarity transformation to isolate eigenvalues
*> in the first 1 to ILO-1 and last IHI+1 to N elements on the
*> diagonal; and second, applying a diagonal similarity transformation
*> to rows and columns ILO to IHI to make the rows and columns as
*> close in norm as possible. Both steps are optional.
*>
*> Balancing may reduce the 1-norm of the matrix, and improve the
*> accuracy of the computed eigenvalues and/or eigenvectors.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies the operations to be performed on A:
*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
*> for i = 1,...,N;
*> = 'P': permute only;
*> = 'S': scale only;
*> = 'B': both permute and scale.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the input matrix A.
*> On exit, A is overwritten by the balanced matrix.
*> If JOB = 'N', A is not referenced.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] ILO
*> \verbatim
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*> ILO and IHI are set to INTEGER such that on exit
*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
*> If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and scaling factors applied to
*> A. If P(j) is the index of the row and column interchanged
*> with row and column j and D(j) is the scaling factor
*> applied to row and column j, then
*> SCALE(j) = P(j) for j = 1,...,ILO-1
*> = D(j) for j = ILO,...,IHI
*> = P(j) for j = IHI+1,...,N.
*> The order in which the interchanges are made is N to IHI+1,
*> then 1 to ILO-1.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The permutations consist of row and column interchanges which put
*> the matrix in the form
*>
*> ( T1 X Y )
*> P A P = ( 0 B Z )
*> ( 0 0 T2 )
*>
*> where T1 and T2 are upper triangular matrices whose eigenvalues lie
*> along the diagonal. The column indices ILO and IHI mark the starting
*> and ending columns of the submatrix B. Balancing consists of applying
*> a diagonal similarity transformation inv(D) * B * D to make the
*> 1-norms of each row of B and its corresponding column nearly equal.
*> The output matrix is
*>
*> ( T1 X*D Y )
*> ( 0 inv(D)*B*D inv(D)*Z ).
*> ( 0 0 T2 )
*>
*> Information about the permutations P and the diagonal matrix D is
*> returned in the vector SCALE.
*>
*> This subroutine is based on the EISPACK routine CBAL.
*>
*> Modified by Tzu-Yi Chen, Computer Science Division, University of
*> California at Berkeley, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SCALE( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION SCLFAC
PARAMETER ( SCLFAC = 2.0D+0 )
DOUBLE PRECISION FACTOR
PARAMETER ( FACTOR = 0.95D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOCONV
INTEGER I, ICA, IEXC, IRA, J, K, L, M
DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
$ SFMIN2
COMPLEX*16 CDUM
* ..
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH, DZNRM2
EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEBAL', -INFO )
RETURN
END IF
*
K = 1
L = N
*
IF( N.EQ.0 )
$ GO TO 210
*
IF( LSAME( JOB, 'N' ) ) THEN
DO 10 I = 1, N
SCALE( I ) = ONE
10 CONTINUE
GO TO 210
END IF
*
IF( LSAME( JOB, 'S' ) )
$ GO TO 120
*
* Permutation to isolate eigenvalues if possible
*
GO TO 50
*
* Row and column exchange.
*
20 CONTINUE
SCALE( M ) = J
IF( J.EQ.M )
$ GO TO 30
*
CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
*
30 CONTINUE
GO TO ( 40, 80 )IEXC
*
* Search for rows isolating an eigenvalue and push them down.
*
40 CONTINUE
IF( L.EQ.1 )
$ GO TO 210
L = L - 1
*
50 CONTINUE
DO 70 J = L, 1, -1
*
DO 60 I = 1, L
IF( I.EQ.J )
$ GO TO 60
IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE.
$ ZERO )GO TO 70
60 CONTINUE
*
M = L
IEXC = 1
GO TO 20
70 CONTINUE
*
GO TO 90
*
* Search for columns isolating an eigenvalue and push them left.
*
80 CONTINUE
K = K + 1
*
90 CONTINUE
DO 110 J = K, L
*
DO 100 I = K, L
IF( I.EQ.J )
$ GO TO 100
IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE.
$ ZERO )GO TO 110
100 CONTINUE
*
M = K
IEXC = 2
GO TO 20
110 CONTINUE
*
120 CONTINUE
DO 130 I = K, L
SCALE( I ) = ONE
130 CONTINUE
*
IF( LSAME( JOB, 'P' ) )
$ GO TO 210
*
* Balance the submatrix in rows K to L.
*
* Iterative loop for norm reduction
*
SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
*
C = DZNRM2( L-K+1, A( K, I ), 1 )
R = DZNRM2( L-K+1, A( I, K ), LDA )
ICA = IZAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IZAMAX( N-K+1, A( I, K ), LDA )
RA = ABS( A( I, IRA+K-1 ) )
*
* Guard against zero C or R due to underflow.
*
IF( C.EQ.ZERO .OR. R.EQ.ZERO )
$ GO TO 200
G = R / SCLFAC
F = ONE
S = C + R
160 CONTINUE
IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
$ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
IF( DISNAN( C+F+CA+R+G+RA ) ) THEN
*
* Exit if NaN to avoid infinite loop
*
INFO = -3
CALL XERBLA( 'ZGEBAL', -INFO )
RETURN
END IF
F = F*SCLFAC
C = C*SCLFAC
CA = CA*SCLFAC
R = R / SCLFAC
G = G / SCLFAC
RA = RA / SCLFAC
GO TO 160
*
170 CONTINUE
G = C / SCLFAC
180 CONTINUE
IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
$ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
F = F / SCLFAC
C = C / SCLFAC
G = G / SCLFAC
CA = CA / SCLFAC
R = R*SCLFAC
RA = RA*SCLFAC
GO TO 180
*
* Now balance.
*
190 CONTINUE
IF( ( C+R ).GE.FACTOR*S )
$ GO TO 200
IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
IF( F*SCALE( I ).LE.SFMIN1 )
$ GO TO 200
END IF
IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
IF( SCALE( I ).GE.SFMAX1 / F )
$ GO TO 200
END IF
G = ONE / F
SCALE( I ) = SCALE( I )*F
NOCONV = .TRUE.
*
CALL ZDSCAL( N-K+1, G, A( I, K ), LDA )
CALL ZDSCAL( L, F, A( 1, I ), 1 )
*
200 CONTINUE
*
IF( NOCONV )
$ GO TO 140
*
210 CONTINUE
ILO = K
IHI = L
*
RETURN
*
* End of ZGEBAL
*
END
*> \brief \b ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBD2 reduces a complex general m by n matrix A to upper or lower
*> real bidiagonal form B by a unitary transformation: Q**H * A * P = B.
*>
*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n general matrix to be reduced.
*> On exit,
*> if m >= n, the diagonal and the first superdiagonal are
*> overwritten with the upper bidiagonal matrix B; the
*> elements below the diagonal, with the array TAUQ, represent
*> the unitary matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors;
*> if m < n, the diagonal and the first subdiagonal are
*> overwritten with the lower bidiagonal matrix B; the
*> elements below the first subdiagonal, with the array TAUQ,
*> represent the unitary matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (min(M,N))
*> The diagonal elements of the bidiagonal matrix B:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (min(M,N)-1)
*> The off-diagonal elements of the bidiagonal matrix B:
*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (max(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.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> If m >= n,
*>
*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
*> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n,
*>
*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, v and u are complex vectors;
*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
*> tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The contents of A on exit are illustrated by the following examples:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
*> ( v1 v2 v3 v4 v5 )
*>
*> where d and e denote diagonal and off-diagonal elements of B, vi
*> denotes an element of the vector defining H(i), and ui an element of
*> the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'ZGEBD2', -INFO )
RETURN
END IF
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, N
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
ALPHA = A( I, I )
CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = ALPHA
A( I, I ) = ONE
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.N ) THEN
*
* Generate elementary reflector G(i) to annihilate
* A(i,i+2:n)
*
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
ALPHA = A( I, I+1 )
CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
$ TAUP( I ) )
E( I ) = ALPHA
A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I+1 ) = E( I )
ELSE
TAUP( I ) = ZERO
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, M
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = ALPHA
A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
CALL ZLACGV( N-I+1, A( I, I ), LDA )
A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Apply H(i)**H to A(i+1:m,i+1:n) from the left
*
CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
$ WORK )
A( I+1, I ) = E( I )
ELSE
TAUQ( I ) = ZERO
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZGEBD2
*
END
*> \brief \b ZGEBRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
*> bidiagonal form B by a unitary transformation: Q**H * A * P = B.
*>
*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N general matrix to be reduced.
*> On exit,
*> if m >= n, the diagonal and the first superdiagonal are
*> overwritten with the upper bidiagonal matrix B; the
*> elements below the diagonal, with the array TAUQ, represent
*> the unitary matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors;
*> if m < n, the diagonal and the first subdiagonal are
*> overwritten with the lower bidiagonal matrix B; the
*> elements below the first subdiagonal, with the array TAUQ,
*> represent the unitary matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (min(M,N))
*> The diagonal elements of the bidiagonal matrix B:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (min(M,N)-1)
*> The off-diagonal elements of the bidiagonal matrix B:
*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 length of the array WORK. LWORK >= max(1,M,N).
*> For optimum performance LWORK >= (M+N)*NB, where NB
*> is the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> If m >= n,
*>
*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
*> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n,
*>
*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The contents of A on exit are illustrated by the following examples:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
*> ( v1 v2 v3 v4 v5 )
*>
*> where d and e denote diagonal and off-diagonal elements of B, vi
*> denotes an element of the vector defining H(i), and ui an element of
*> the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
$ NBMIN, NX
DOUBLE PRECISION WS
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
LWKOPT = ( M+N )*NB
WORK( 1 ) = DBLE( LWKOPT )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'ZGEBRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
WS = MAX( M, N )
LDWRKX = M
LDWRKY = N
*
IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
*
* Set the crossover point NX.
*
NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
*
* Determine when to switch from blocked to unblocked code.
*
IF( NX.LT.MINMN ) THEN
WS = ( M+N )*NB
IF( LWORK.LT.WS ) THEN
*
* Not enough work space for the optimal NB, consider using
* a smaller block size.
*
NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 )
IF( LWORK.GE.( M+N )*NBMIN ) THEN
NB = LWORK / ( M+N )
ELSE
NB = 1
NX = MINMN
END IF
END IF
END IF
ELSE
NX = MINMN
END IF
*
DO 30 I = 1, MINMN - NX, NB
*
* Reduce rows and columns i:i+ib-1 to bidiagonal form and return
* the matrices X and Y which are needed to update the unreduced
* part of the matrix
*
CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
$ WORK( LDWRKX*NB+1 ), LDWRKY )
*
* Update the trailing submatrix A(i+ib:m,i+ib:n), using
* an update of the form A := A - V*Y**H - X*U**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1,
$ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA,
$ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
$ A( I+NB, I+NB ), LDA )
CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
$ ONE, A( I+NB, I+NB ), LDA )
*
* Copy diagonal and off-diagonal elements of B back into A
*
IF( M.GE.N ) THEN
DO 10 J = I, I + NB - 1
A( J, J ) = D( J )
A( J, J+1 ) = E( J )
10 CONTINUE
ELSE
DO 20 J = I, I + NB - 1
A( J, J ) = D( J )
A( J+1, J ) = E( J )
20 CONTINUE
END IF
30 CONTINUE
*
* Use unblocked code to reduce the remainder of the matrix
*
CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, IINFO )
WORK( 1 ) = WS
RETURN
*
* End of ZGEBRD
*
END
*> \brief \b ZGECON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGECON + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGECON estimates the reciprocal of the condition number of a general
*> complex matrix A, in either the 1-norm or the infinity-norm, using
*> the LU factorization computed by ZGETRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as
*> RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies whether the 1-norm condition number or the
*> infinity-norm condition number is required:
*> = '1' or 'O': 1-norm;
*> = 'I': Infinity-norm.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by ZGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> If NORM = '1' or 'O', the 1-norm of the original matrix A.
*> If NORM = 'I', the infinity-norm of the original matrix A.
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(norm(A) * norm(inv(A))).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IZAMAX, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGECON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
CALL ZLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, RWORK, INFO )
*
* Multiply by inv(U).
*
CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
$ A, LDA, WORK, SU, RWORK( N+1 ), INFO )
ELSE
*
* Multiply by inv(U**H).
*
CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ),
$ INFO )
*
* Multiply by inv(L**H).
*
CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Unit', NORMIN,
$ N, A, LDA, WORK, SL, RWORK, INFO )
END IF
*
* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*
SCALE = SL*SU
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = IZAMAX( N, WORK, 1 )
IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL ZDRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
20 CONTINUE
RETURN
*
* End of ZGECON
*
END
*> \brief ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
* WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVL, JOBVR
* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues and, optionally, the left and/or right eigenvectors.
*>
*> The right eigenvector v(j) of A satisfies
*> A * v(j) = lambda(j) * v(j)
*> where lambda(j) is its eigenvalue.
*> The left eigenvector u(j) of A satisfies
*> u(j)**H * A = lambda(j) * u(j)**H
*> where u(j)**H denotes the conjugate transpose of u(j).
*>
*> The computed eigenvectors are normalized to have Euclidean norm
*> equal to 1 and largest component real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVL
*> \verbatim
*> JOBVL is CHARACTER*1
*> = 'N': left eigenvectors of A are not computed;
*> = 'V': left eigenvectors of are computed.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*> JOBVR is CHARACTER*1
*> = 'N': right eigenvectors of A are not computed;
*> = 'V': right eigenvectors of A are computed.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N matrix A.
*> On exit, A has been overwritten.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> W contains the computed eigenvalues.
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,N)
*> If JOBVL = 'V', the left eigenvectors u(j) are stored one
*> after another in the columns of VL, in the same order
*> as their eigenvalues.
*> If JOBVL = 'N', VL is not referenced.
*> u(j) = VL(:,j), the j-th column of VL.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the array VL. LDVL >= 1; if
*> JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,N)
*> If JOBVR = 'V', the right eigenvectors v(j) are stored one
*> after another in the columns of VR, in the same order
*> as their eigenvalues.
*> If JOBVR = 'N', VR is not referenced.
*> v(j) = VR(:,j), the j-th column of VR.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR. LDVR >= 1; if
*> JOBVR = 'V', LDVR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,2*N).
*> For good performance, LWORK must generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*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: if INFO = i, the QR algorithm failed to compute all the
*> eigenvalues, and no eigenvectors have been computed;
*> elements and i+1:N of W contain eigenvalues which have
*> converged.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEeigen
*
* =====================================================================
SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
$ WORK, LWORK, RWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
$ W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
CHARACTER SIDE
INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
$ IWRK, K, MAXWRK, MINWRK, NOUT
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
COMPLEX*16 TMP
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
$ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, ILAENV
DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE
EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* 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.
* HSWORK refers to the workspace preferred by ZHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
MINWRK = 2*N
IF( WANTVL ) THEN
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
$ WORK, -1, INFO )
ELSE IF( WANTVR ) THEN
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
$ WORK, -1, INFO )
ELSE
CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
$ WORK, -1, INFO )
END IF
HSWORK = WORK( 1 )
MAXWRK = MAX( MAXWRK, HSWORK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix
* (CWorkspace: none)
* (RWorkspace: need N)
*
IBAL = 1
CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: none)
*
ITAU = 1
IWRK = ITAU + N
CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate unitary matrix in VL
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate unitary matrix in VR
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO > 0 from ZHSEQR, then quit
*
IF( INFO.GT.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (CWorkspace: need 2*N)
* (RWorkspace: need 2*N)
*
IRWORK = IBAL + N
CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
SCL = ONE / DZNRM2( N, VL( 1, I ), 1 )
CALL ZDSCAL( N, SCL, VL( 1, I ), 1 )
DO 10 K = 1, N
RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 +
$ DIMAG( VL( K, I ) )**2
10 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
CALL ZSCAL( N, TMP, VL( 1, I ), 1 )
VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO )
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
SCL = ONE / DZNRM2( N, VR( 1, I ), 1 )
CALL ZDSCAL( N, SCL, VR( 1, I ), 1 )
DO 30 K = 1, N
RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 +
$ DIMAG( VR( K, I ) )**2
30 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
CALL ZSCAL( N, TMP, VR( 1, I ), 1 )
VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO )
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.GT.0 ) THEN
CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of ZGEEV
*
END
*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEHD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
*> by a unitary similarity transformation: Q**H * A * Q = H .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that A is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL; otherwise they should be
*> set to 1 and N respectively. See Further Details.
*> 1 <= ILO <= IHI <= max(1,N).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the n by n general matrix to be reduced.
*> On exit, the upper triangle and the first subdiagonal of A
*> are overwritten with the upper Hessenberg matrix H, and the
*> elements below the first subdiagonal, with the array TAU,
*> represent the unitary matrix Q as a product of elementary
*> reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of (ihi-ilo) elementary
*> reflectors
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*> exit in A(i+2:ihi,i), and tau in TAU(i).
*>
*> The contents of A are illustrated by the following example, with
*> n = 7, ilo = 2 and ihi = 6:
*>
*> on entry, on exit,
*>
*> ( a a a a a a a ) ( a a h h h h a )
*> ( a a a a a a ) ( a h h h h a )
*> ( a a a a a a ) ( h h h h h h )
*> ( a a a a a a ) ( v2 h h h h h )
*> ( a a a a a a ) ( v2 v3 h h h h )
*> ( a a a a a a ) ( v2 v3 v4 h h h )
*> ( a ) ( a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEHD2', -INFO )
RETURN
END IF
*
DO 10 I = ILO, IHI - 1
*
* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) )
A( I+1, I ) = ONE
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
$ A( 1, I+1 ), LDA, WORK )
*
* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
*
CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
$ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
*
A( I+1, I ) = ALPHA
10 CONTINUE
*
RETURN
*
* End of ZGEHD2
*
END
*> \brief \b ZGEHRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEHRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
*> an unitary similarity transformation: Q**H * A * Q = H .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that A is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL; otherwise they should be
*> set to 1 and N respectively. See Further Details.
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N general matrix to be reduced.
*> On exit, the upper triangle and the first subdiagonal of A
*> are overwritten with the upper Hessenberg matrix H, and the
*> elements below the first subdiagonal, with the array TAU,
*> represent the unitary matrix Q as a product of elementary
*> reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
*> zero.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of (ihi-ilo) elementary
*> reflectors
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*> exit in A(i+2:ihi,i), and tau in TAU(i).
*>
*> The contents of A are illustrated by the following example, with
*> n = 7, ilo = 2 and ihi = 6:
*>
*> on entry, on exit,
*>
*> ( a a a a a a a ) ( a a h h h h a )
*> ( a a a a a a ) ( a h h h h a )
*> ( a a a a a a ) ( h h h h h h )
*> ( a a a a a a ) ( v2 h h h h h )
*> ( a a a a a a ) ( v2 v3 h h h h )
*> ( a a a a a a ) ( v2 v3 v4 h h h )
*> ( a ) ( a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*>
*> This file is a slight modification of LAPACK-3.0's DGEHRD
*> subroutine incorporating improvements proposed by Quintana-Orti and
*> Van de Geijn (2006). (See DLAHR2.)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
$ NBMIN, NH, NX
COMPLEX*16 EI
* ..
* .. Local Arrays ..
COMPLEX*16 T( LDT, NBMAX )
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEHRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
*
DO 10 I = 1, ILO - 1
TAU( I ) = ZERO
10 CONTINUE
DO 20 I = MAX( 1, IHI ), N - 1
TAU( I ) = ZERO
20 CONTINUE
*
* Quick return if possible
*
NH = IHI - ILO + 1
IF( NH.LE.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size
*
NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
NBMIN = 2
IWS = 1
IF( NB.GT.1 .AND. NB.LT.NH ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code)
*
NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
IF( NX.LT.NH ) THEN
*
* Determine if workspace is large enough for blocked code
*
IWS = N*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code
*
NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI,
$ -1 ) )
IF( LWORK.GE.N*NBMIN ) THEN
NB = LWORK / N
ELSE
NB = 1
END IF
END IF
END IF
END IF
LDWORK = N
*
IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
*
* Use unblocked code below
*
I = ILO
*
ELSE
*
* Use blocked code
*
DO 40 I = ILO, IHI - 1 - NX, NB
IB = MIN( NB, IHI-I )
*
* Reduce columns i:i+ib-1 to Hessenberg form, returning the
* matrices V and T of the block reflector H = I - V*T*V**H
* which performs the reduction, and also the matrix Y = A*V*T
*
CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
$ WORK, LDWORK )
*
* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set
* to 1
*
EI = A( I+IB, I+IB-1 )
A( I+IB, I+IB-1 ) = ONE
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ IHI, IHI-I-IB+1,
$ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
$ A( 1, I+IB ), LDA )
A( I+IB, I+IB-1 ) = EI
*
* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
* right
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', I, IB-1,
$ ONE, A( I+1, I ), LDA, WORK, LDWORK )
DO 30 J = 0, IB-2
CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
$ A( 1, I+J+1 ), 1 )
30 CONTINUE
*
* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
* left
*
CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
$ 'Columnwise',
$ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
$ A( I+1, I+IB ), LDA, WORK, LDWORK )
40 CONTINUE
END IF
*
* Use unblocked code to reduce the rest of the matrix
*
CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
WORK( 1 ) = IWS
*
RETURN
*
* End of ZGEHRD
*
END
*> \brief \b ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELQ2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
*> A = L * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m by min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
*> A(i,i+1:n), and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, K
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAU( I ) )
IF( I.LT.M ) THEN
*
* Apply H(i) to A(i+1:m,i:n) from the right
*
A( I, I ) = ONE
CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
$ A( I+1, I ), LDA, WORK )
END IF
A( I, I ) = ALPHA
CALL ZLACGV( N-I+1, A( I, I ), LDA )
10 CONTINUE
RETURN
*
* End of ZGELQ2
*
END
*> \brief \b ZGELQF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELQF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
*> A = L * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
*> A(i,i+1:n), and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
K = MIN( M, N )
IF( K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code initially
*
DO 10 I = 1, K - NX, NB
IB = MIN( K-I+1, NB )
*
* Compute the LQ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i+ib:m,i:n) from the right
*
CALL ZLARFB( 'Right', 'No transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
ELSE
I = 1
END IF
*
* Use unblocked code to factor the last or only block.
*
IF( I.LE.K )
$ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGELQF
*
END
*> \brief \b ZGEQP3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQP3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* INTEGER JPVT( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEQP3 computes a QR factorization with column pivoting of a
*> matrix A: A*P = Q*R using Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the upper triangle of the array contains the
*> min(M,N)-by-N upper trapezoidal matrix R; the elements below
*> the diagonal, together with the array TAU, represent the
*> unitary matrix Q as a product of min(M,N) elementary
*> reflectors.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] JPVT
*> \verbatim
*> JPVT is INTEGER array, dimension (N)
*> On entry, if JPVT(J).ne.0, the J-th column of A is permuted
*> to the front of A*P (a leading column); if JPVT(J)=0,
*> the J-th column of A is a free column.
*> On exit, if JPVT(J)=K, then the J-th column of A*P was the
*> the K-th column of A.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 >= N+1.
*> For optimal performance LWORK >= ( N+1 )*NB, where NB
*> is the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a real/complex vector
*> with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
*> A(i+1:m,i), and tau in TAU(i).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*> X. Sun, Computer Science Dept., Duke University, USA
*>
* =====================================================================
SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER INB, INBMIN, IXOVER
PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
$ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DZNRM2
EXTERNAL ILAENV, DZNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test input arguments
* ====================
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
*
IF( INFO.EQ.0 ) THEN
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
IWS = 1
LWKOPT = 1
ELSE
IWS = N + 1
NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 )
LWKOPT = ( N + 1 )*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQP3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( MINMN.EQ.0 ) THEN
RETURN
END IF
*
* Move initial columns up front.
*
NFXD = 1
DO 10 J = 1, N
IF( JPVT( J ).NE.0 ) THEN
IF( J.NE.NFXD ) THEN
CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
JPVT( J ) = JPVT( NFXD )
JPVT( NFXD ) = J
ELSE
JPVT( J ) = J
END IF
NFXD = NFXD + 1
ELSE
JPVT( J ) = J
END IF
10 CONTINUE
NFXD = NFXD - 1
*
* Factorize fixed columns
* =======================
*
* Compute the QR factorization of fixed columns and update
* remaining columns.
*
IF( NFXD.GT.0 ) THEN
NA = MIN( M, NFXD )
*CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
IWS = MAX( IWS, INT( WORK( 1 ) ) )
IF( NA.LT.N ) THEN
*CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA,
*CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK,
*CC $ INFO )
CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A,
$ LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK,
$ INFO )
IWS = MAX( IWS, INT( WORK( 1 ) ) )
END IF
END IF
*
* Factorize free columns
* ======================
*
IF( NFXD.LT.MINMN ) THEN
*
SM = M - NFXD
SN = N - NFXD
SMINMN = MINMN - NFXD
*
* Determine the block size.
*
NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 )
NBMIN = 2
NX = 0
*
IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1,
$ -1 ) )
*
*
IF( NX.LT.SMINMN ) THEN
*
* Determine if workspace is large enough for blocked code.
*
MINWS = ( SN+1 )*NB
IWS = MAX( IWS, MINWS )
IF( LWORK.LT.MINWS ) THEN
*
* Not enough workspace to use optimal NB: Reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / ( SN+1 )
NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN,
$ -1, -1 ) )
*
*
END IF
END IF
END IF
*
* Initialize partial column norms. The first N elements of work
* store the exact column norms.
*
DO 20 J = NFXD + 1, N
RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 )
RWORK( N+J ) = RWORK( J )
20 CONTINUE
*
IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
$ ( NX.LT.SMINMN ) ) THEN
*
* Use blocked code initially.
*
J = NFXD + 1
*
* Compute factorization: while loop.
*
*
TOPBMN = MINMN - NX
30 CONTINUE
IF( J.LE.TOPBMN ) THEN
JB = MIN( NB, TOPBMN-J+1 )
*
* Factorize JB columns among columns J:N.
*
CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
$ JPVT( J ), TAU( J ), RWORK( J ),
$ RWORK( N+J ), WORK( 1 ), WORK( JB+1 ),
$ N-J+1 )
*
J = J + FJB
GO TO 30
END IF
ELSE
J = NFXD + 1
END IF
*
* Use unblocked code to factor the last or only block.
*
*
IF( J.LE.MINMN )
$ CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
$ TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) )
*
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGEQP3
*
END
*> \brief \b ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEQR2 computes a QR factorization of a complex m by n matrix A:
*> A = Q * R.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and above the diagonal of the array
*> contain the min(m,n) by n upper trapezoidal matrix R (R is
*> upper triangular if m >= n); the elements below the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, K
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQR2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAU( I ) )
IF( I.LT.N ) THEN
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
ALPHA = A( I, I )
A( I, I ) = ONE
CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
$ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
A( I, I ) = ALPHA
END IF
10 CONTINUE
RETURN
*
* End of ZGEQR2
*
END
*> \brief \b ZGEQRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
*> A = Q * R.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is
*> upper triangular if m >= n); the elements below the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of min(m,n) elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
K = MIN( M, N )
IF( K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code initially
*
DO 10 I = 1, K - NX, NB
IB = MIN( K-I+1, NB )
*
* Compute the QR factorization of the current block
* A(i:m,i:i+ib-1)
*
CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.N ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**H to A(i:m,i+ib:n) from the left
*
CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
ELSE
I = 1
END IF
*
* Use unblocked code to factor the last or only block.
*
IF( I.LE.K )
$ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGEQRF
*
END
*> \brief ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESV computes the solution to a complex system of linear equations
*> A * X = B,
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as
*> A = P * L * U,
*> where P is a permutation matrix, L is unit lower triangular, and U is
*> upper triangular. The factored form of A is then used to solve the
*> system of equations A * X = B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N coefficient matrix A.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices that define the permutation matrix P;
*> row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS matrix of right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,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: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEsolve
*
* =====================================================================
SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL XERBLA, ZGETRF, ZGETRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of A.
*
CALL ZGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* End of ZGESV
*
END
*> \brief ZGESVD computes the singular value decomposition (SVD) for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESVD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
* WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBU, JOBVT
* INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), S( * )
* COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESVD computes the singular value decomposition (SVD) of a complex
*> M-by-N matrix A, optionally computing the left and/or right singular
*> vectors. 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 V**H, not V.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBU
*> \verbatim
*> JOBU is CHARACTER*1
*> Specifies options for computing all or part of the matrix U:
*> = 'A': all M columns of U are returned in array U:
*> = 'S': the first min(m,n) columns of U (the left singular
*> vectors) are returned in the array U;
*> = 'O': the first min(m,n) columns of U (the left singular
*> vectors) are overwritten on the array A;
*> = 'N': no columns of U (no left singular vectors) are
*> computed.
*> \endverbatim
*>
*> \param[in] JOBVT
*> \verbatim
*> JOBVT is CHARACTER*1
*> Specifies options for computing all or part of the matrix
*> V**H:
*> = 'A': all N rows of V**H are returned in the array VT;
*> = 'S': the first min(m,n) rows of V**H (the right singular
*> vectors) are returned in the array VT;
*> = 'O': the first min(m,n) rows of V**H (the right singular
*> vectors) are overwritten on the array A;
*> = 'N': no rows of V**H (no right singular vectors) are
*> computed.
*>
*> JOBVT and JOBU cannot both be 'O'.
*> \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*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit,
*> if JOBU = 'O', A is overwritten with the first min(m,n)
*> columns of U (the left singular vectors,
*> stored columnwise);
*> if JOBVT = 'O', A is overwritten with the first min(m,n)
*> rows of V**H (the right singular vectors,
*> stored rowwise);
*> if JOBU .ne. 'O' and JOBVT .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 DOUBLE PRECISION 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*16 array, dimension (LDU,UCOL)
*> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
*> If JOBU = 'A', U contains the M-by-M unitary matrix U;
*> if JOBU = 'S', U contains the first min(m,n) columns of U
*> (the left singular vectors, stored columnwise);
*> if JOBU = 'N' or 'O', U is not referenced.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> The leading dimension of the array U. LDU >= 1; if
*> JOBU = 'S' or 'A', LDU >= M.
*> \endverbatim
*>
*> \param[out] VT
*> \verbatim
*> VT is COMPLEX*16 array, dimension (LDVT,N)
*> If JOBVT = 'A', VT contains the N-by-N unitary matrix
*> V**H;
*> if JOBVT = 'S', VT contains the first min(m,n) rows of
*> V**H (the right singular vectors, stored rowwise);
*> if JOBVT = 'N' or 'O', VT is not referenced.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*> LDVT is INTEGER
*> The leading dimension of the array VT. LDVT >= 1; if
*> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).
*> For good performance, LWORK should generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (5*min(M,N))
*> On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
*> unconverged superdiagonal elements of an upper bidiagonal
*> matrix B whose diagonal is in S (not necessarily sorted).
*> B satisfies A = U * B * VT, so it has the same singular
*> values as A, and singular vectors related by U and VT.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if ZBDSQR did not converge, INFO specifies how many
*> superdiagonals of an intermediate bidiagonal form B
*> did not converge to zero. See the description of RWORK
*> above for details.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16GEsing
*
* =====================================================================
SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, WORK, LWORK, RWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), S( * )
COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
$ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
$ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
$ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
$ NRVT, WRKBL
INTEGER LWORK_ZGEQRF, LWORK_ZUNGQR_N, LWORK_ZUNGQR_M,
$ LWORK_ZGEBRD, LWORK_ZUNGBR_P, LWORK_ZUNGBR_Q,
$ LWORK_ZGELQF, LWORK_ZUNGLQ_N, LWORK_ZUNGLQ_M
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
COMPLEX*16 CDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM,
$ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ,
$ ZUNGQR, ZUNMBR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTUA = LSAME( JOBU, 'A' )
WNTUS = LSAME( JOBU, 'S' )
WNTUAS = WNTUA .OR. WNTUS
WNTUO = LSAME( JOBU, 'O' )
WNTUN = LSAME( JOBU, 'N' )
WNTVA = LSAME( JOBVT, 'A' )
WNTVS = LSAME( JOBVT, 'S' )
WNTVAS = WNTVA .OR. WNTVS
WNTVO = LSAME( JOBVT, 'O' )
WNTVN = LSAME( JOBVT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
INFO = -1
ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
$ ( WNTVO .AND. WNTUO ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
INFO = -9
ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
$ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* 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.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Space needed for ZBDSQR is BDSPAC = 5*N
*
MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
* Compute space needed for ZGEQRF
CALL ZGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEQRF=CDUM(1)
* Compute space needed for ZUNGQR
CALL ZUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGQR_N=CDUM(1)
CALL ZUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGQR_M=CDUM(1)
* Compute space needed for ZGEBRD
CALL ZGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD=CDUM(1)
* Compute space needed for ZUNGBR
CALL ZUNGBR( 'P', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P=CDUM(1)
CALL ZUNGBR( 'Q', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q=CDUM(1)
*
IF( M.GE.MNTHR ) THEN
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
*
MAXWRK = N + LWORK_ZGEQRF
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZGEBRD )
IF( WNTVO .OR. WNTVAS )
$ MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
MINWRK = 3*N
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
MINWRK = 2*N + M
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = 2*N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = 2*N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
END IF
ELSE
*
* Path 10 (M at least N, but not much larger)
*
CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD=CDUM(1)
MAXWRK = 2*N + LWORK_ZGEBRD
IF( WNTUS .OR. WNTUO ) THEN
CALL ZUNGBR( 'Q', M, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q=CDUM(1)
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
END IF
IF( WNTUA ) THEN
CALL ZUNGBR( 'Q', M, M, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q=CDUM(1)
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
END IF
IF( .NOT.WNTVN ) THEN
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
MINWRK = 2*N + M
END IF
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Space needed for ZBDSQR is BDSPAC = 5*M
*
MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
* Compute space needed for ZGELQF
CALL ZGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGELQF=CDUM(1)
* Compute space needed for ZUNGLQ
CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGLQ_N=CDUM(1)
CALL ZUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGLQ_M=CDUM(1)
* Compute space needed for ZGEBRD
CALL ZGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD=CDUM(1)
* Compute space needed for ZUNGBR P
CALL ZUNGBR( 'P', M, M, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P=CDUM(1)
* Compute space needed for ZUNGBR Q
CALL ZUNGBR( 'Q', M, M, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q=CDUM(1)
IF( N.GE.MNTHR ) THEN
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
*
MAXWRK = M + LWORK_ZGELQF
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZGEBRD )
IF( WNTUO .OR. WNTUAS )
$ MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
MINWRK = 3*M
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
MINWRK = 2*M + N
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A',
* JOBVT='O')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = 2*M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = 2*M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
END IF
ELSE
*
* Path 10t(N greater than M, but not much larger)
*
CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD=CDUM(1)
MAXWRK = 2*M + LWORK_ZGEBRD
IF( WNTVS .OR. WNTVO ) THEN
* Compute space needed for ZUNGBR P
CALL ZUNGBR( 'P', M, N, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P=CDUM(1)
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
END IF
IF( WNTVA ) THEN
CALL ZUNGBR( 'P', N, N, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P=CDUM(1)
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
END IF
IF( .NOT.WNTUN ) THEN
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
MINWRK = 2*M + N
END IF
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* 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
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
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.MNTHR ) THEN
*
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
* No left singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: need 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+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
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
NCVT = 0
IF( WNTVO .OR. WNTVAS ) THEN
*
* If right singular vectors desired, generate P'.
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
NCVT = N
END IF
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A if desired
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
$ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
*
* If right singular vectors desired in VT, copy them there
*
IF( WNTVAS )
$ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
*
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
* N left singular vectors to be overwritten on A and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR) and zero 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 N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: need 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
$ WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (CWorkspace: need N*N+N, prefer N*N+M*N)
* (RWorkspace: 0)
*
DO 10 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing A
* (CWorkspace: need 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A
* (CWorkspace: need 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
$ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR) and computing right
* singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (CWorkspace: need N*N+N, prefer N*N+M*N)
* (RWorkspace: 0)
*
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
20 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in A by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUS ) THEN
*
IF( WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
* N left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+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 N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
$ 1, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IR ), LDWRKR, CZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
$ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
* N left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*N*N+3*N,
* prefer 2*N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*N*N+3*N-1,
* prefer 2*N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (CWorkspace: need 2*N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IU ), LDWRKU, CZERO, U, LDU )
*
* Copy right singular vectors of R to A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
* or 'A')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need N*N+3*N-1,
* prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IU ), LDWRKU, CZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
ELSE IF( WNTUA ) THEN
*
IF( WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
* M left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* 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 U
* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
$ 1, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IR), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
$ WORK( IR ), LDWRKR, CZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
$ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
* M left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*N*N+3*N,
* prefer 2*N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*N*N+3*N-1,
* prefer 2*N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (CWorkspace: need 2*N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( '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 ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
* Copy right singular vectors of R from WORK(IR) to A
*
CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
* or 'A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need N*N+3*N-1,
* prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: need 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( '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 ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R from A to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 10 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
IF( WNTUS )
$ NCU = N
IF( WNTUA )
$ NCU = M
CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (CWorkspace: need 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + N
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
* No right singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out above L
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
$ LDA )
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUO .OR. WNTUAS ) THEN
*
* If left singular vectors desired, generate Q
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + M
NRU = 0
IF( WNTUO .OR. WNTUAS )
$ NRU = M
*
* Perform bidiagonal QR iteration, computing left singular
* vectors of A in A if desired
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
$ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
*
* If left singular vectors desired in U, copy them there
*
IF( WNTUAS )
$ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
*
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
* M right singular vectors to be overwritten on A and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR) and zero out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L
* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (CWorkspace: need M*M+M, prefer M*M+M*N)
* (RWorkspace: 0)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
$ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing about above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U, copying result to WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
*
* Generate right vectors bidiagonalizing L in WORK(IR)
* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U, and computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (CWorkspace: need M*M+M, prefer M*M+M*N))
* (RWorkspace: 0)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
40 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in A
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
$ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTVS ) THEN
*
IF( WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
* M right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L in
* WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
$ LDWRKR, A, LDA, CZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy result to VT
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
$ LDVT, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*M*M+3*M,
* prefer 2*M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*M*M+3*M-1,
* prefer 2*M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (CWorkspace: need 2*M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, A, LDA, CZERO, VT, LDVT )
*
* Copy left singular vectors of L to A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors of L in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is LDA by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need M*M+3*M-1,
* prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, A, LDA, CZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ U( 1, 2 ), LDU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
ELSE IF( WNTVA ) THEN
*
IF( WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
* N right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in VT
* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need M*M+3*M-1,
* prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
$ LDWRKR, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
$ LDVT, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*M*M+3*M,
* prefer 2*M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*M*M+3*M-1,
* prefer 2*M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (CWorkspace: need 2*M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
* Copy left singular vectors of A from WORK(IR) to A
*
CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by M
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is M by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ U( 1, 2 ), LDU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 10t(N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
IF( WNTVA )
$ NRVT = N
IF( WNTVS )
$ NRVT = M
CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + M
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
IF( ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of ZGESVD
*
END
*> \brief \b ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETF2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETF2 computes an LU factorization of a general m-by-n matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the right-looking Level 2 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
DOUBLE PRECISION SFMIN
INTEGER I, J, JP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IZAMAX
EXTERNAL DLAMCH, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Compute machine safe minimum
*
SFMIN = DLAMCH('S')
*
DO 10 J = 1, MIN( M, N )
*
* Find pivot and test for singularity.
*
JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
IPIV( J ) = JP
IF( A( JP, J ).NE.ZERO ) THEN
*
* Apply the interchange to columns 1:N.
*
IF( JP.NE.J )
$ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
* Compute elements J+1:M of J-th column.
*
IF( J.LT.M ) THEN
IF( ABS(A( J, J )) .GE. SFMIN ) THEN
CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
ELSE
DO 20 I = 1, M-J
A( J+I, J ) = A( J+I, J ) / A( J, J )
20 CONTINUE
END IF
END IF
*
ELSE IF( INFO.EQ.0 ) THEN
*
INFO = J
END IF
*
IF( J.LT.MIN( M, N ) ) THEN
*
* Update trailing submatrix.
*
CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),
$ LDA, A( J+1, J+1 ), LDA )
END IF
10 CONTINUE
RETURN
*
* End of ZGETF2
*
END
*> \brief \b ZGETRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRF computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the right-looking Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IINFO, J, JB, NB
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
* Use unblocked code.
*
CALL ZGETF2( M, N, A, LDA, IPIV, INFO )
ELSE
*
* Use blocked code.
*
DO 20 J = 1, MIN( M, N ), NB
JB = MIN( MIN( M, N )-J+1, NB )
*
* Factor diagonal and subdiagonal blocks and test for exact
* singularity.
*
CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
* Adjust INFO and the pivot indices.
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + J - 1
DO 10 I = J, MIN( M, J+JB-1 )
IPIV( I ) = J - 1 + IPIV( I )
10 CONTINUE
*
* Apply interchanges to columns 1:J-1.
*
CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
IF( J+JB.LE.N ) THEN
*
* Apply interchanges to columns J+JB:N.
*
CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
$ IPIV, 1 )
*
* Compute block row of U.
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
$ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
$ LDA )
IF( J+JB.LE.M ) THEN
*
* Update trailing submatrix.
*
CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1,
$ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
$ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
$ LDA )
END IF
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZGETRF
*
END
*> \brief \b ZGETRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRS solves a system of linear equations
*> A * X = B, A**T * X = B, or A**H * X = B
*> with a general N-by-N matrix A using the LU factorization computed
*> by ZGETRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the form of the system of equations:
*> = 'N': A * X = B (No transpose)
*> = 'T': A**T * X = B (Transpose)
*> = 'C': A**H * X = B (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by ZGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from ZGETRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLASWP, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( NOTRAN ) THEN
*
* Solve A * X = B.
*
* Apply row interchanges to the right hand sides.
*
CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
* Solve L*X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve U*X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* Solve A**T * X = B or A**H * X = B.
*
* Solve U**T *X = B or U**H *X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
$ A, LDA, B, LDB )
*
* Solve L**T *X = B, or L**H *X = B overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
$ LDA, B, LDB )
*
* Apply row interchanges to the solution vectors.
*
CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
END IF
*
RETURN
*
* End of ZGETRS
*
END
*> \brief ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
*> complex Hermitian matrix A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
*> orthonormal eigenvectors of the matrix A.
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
*> or the upper triangle (if UPLO='U') of A, including the
*> diagonal, is destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 length of the array WORK. LWORK >= max(1,2*N-1).
*> For optimal efficiency, LWORK >= (NB+1)*N,
*> where NB is the blocksize for ZHETRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the algorithm failed to converge; i
*> off-diagonal elements of an intermediate tridiagonal
*> form did not converge to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16HEeigen
*
* =====================================================================
SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
$ LLWORK, LWKOPT, NB
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR,
$ ZUNGTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB+1 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY )
$ INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 1
IF( WANTZ )
$ A( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZUNGTR to generate the unitary matrix, then call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
$ LLWORK, IINFO )
INDWRK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA,
$ RWORK( INDWRK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* Set WORK(1) to optimal complex workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZHEEV
*
END
*> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric
*> tridiagonal form T by a unitary similarity transformation:
*> Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
*> of A are overwritten by the corresponding elements of the
*> tridiagonal matrix T, and the elements above the first
*> superdiagonal, with the array TAU, represent the unitary
*> matrix Q as a product of elementary reflectors; if UPLO
*> = 'L', the diagonal and first subdiagonal of A are over-
*> written by the corresponding elements of the tridiagonal
*> matrix T, and the elements below the first subdiagonal, with
*> the array TAU, represent the unitary matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16HEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n-1) . . . H(2) H(1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
*> A(1:i-1,i+1), and tau in TAU(i).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(n-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
*> and tau in TAU(i).
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( d e v2 v3 v4 ) ( d )
*> ( d e v3 v4 ) ( e d )
*> ( d e v4 ) ( v1 e d )
*> ( d e ) ( v1 v2 e d )
*> ( d ) ( v1 v2 v3 e d )
*>
*> where d and e denote diagonal and off-diagonal elements of T, and vi
*> denotes an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U')
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
A( N, N ) = DBLE( A( N, N ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(1:i-1,i+1)
*
ALPHA = A( I, I+1 )
CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
A( I, I+1 ) = ONE
*
* Compute x := tau * A * v storing x in TAU(1:i)
*
CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x**H * v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
ELSE
A( I, I ) = DBLE( A( I, I ) )
END IF
A( I, I+1 ) = E( I )
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
A( 1, 1 ) = DBLE( A( 1, 1 ) )
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
A( I+1, I ) = ONE
*
* Compute x := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* Compute w := x - 1/2 * tau * (x**H * v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
ELSE
A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
END IF
A( I+1, I ) = E( I )
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of ZHETD2
*
END
*> \brief \b ZHETRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETRD reduces a complex Hermitian matrix A to real symmetric
*> tridiagonal form T by a unitary similarity transformation:
*> Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
*> of A are overwritten by the corresponding elements of the
*> tridiagonal matrix T, and the elements above the first
*> superdiagonal, with the array TAU, represent the unitary
*> matrix Q as a product of elementary reflectors; if UPLO
*> = 'L', the diagonal and first subdiagonal of A are over-
*> written by the corresponding elements of the tridiagonal
*> matrix T, and the elements below the first subdiagonal, with
*> the array TAU, represent the unitary matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16HEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n-1) . . . H(2) H(1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
*> A(1:i-1,i+1), and tau in TAU(i).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(n-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
*> and tau in TAU(i).
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( d e v2 v3 v4 ) ( d )
*> ( d e v3 v4 ) ( e d )
*> ( d e v4 ) ( v1 e d )
*> ( d e ) ( v1 v2 e d )
*> ( d ) ( v1 v2 v3 e d )
*>
*> where d and e denote diagonal and off-diagonal elements of T, and vi
*> denotes an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code by setting NX = N.
*
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* Columns 1:kk are handled by the unblocked method.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
* update of the form: A := A - V*W**H - W*V**H
*
CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
$ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* Reduce the lower triangle of A
*
DO 40 I = 1, N - NX, NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+nb:n,i+nb:n), using
* an update of the form: A := A - V*W**H - W*V**H
*
CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZHETRD
*
END
*> \brief \b ZHSEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHSEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
* CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHSEQR computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> = 'E': compute eigenvalues only;
*> = 'S': compute eigenvalues and the Schur form T.
*> \endverbatim
*>
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': no Schur vectors are computed;
*> = 'I': Z is initialized to the unit matrix and the matrix Z
*> of Schur vectors of H is returned;
*> = 'V': Z must contain an unitary matrix Q on entry, and
*> the product Q*Z is returned.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL, and then passed to ZGEHRD
*> when the matrix output by ZGEBAL is reduced to Hessenberg
*> form. Otherwise ILO and IHI should be set to 1 and N
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and JOB = 'S', H contains the upper
*> triangular matrix T from the Schur decomposition (the
*> Schur form). If INFO = 0 and JOB = 'E', the contents of
*> H are unspecified on exit. (The output value of H when
*> INFO.GT.0 is given under the description of INFO below.)
*>
*> Unlike earlier versions of ZHSEQR, this subroutine may
*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
*> or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues. If JOB = 'S', the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If COMPZ = 'N', Z is not referenced.
*> If COMPZ = 'I', on entry Z need not be set and on exit,
*> if INFO = 0, Z contains the unitary matrix Z of the Schur
*> vectors of H. If COMPZ = 'V', on entry Z must contain an
*> N-by-N matrix Q, which is assumed to be equal to the unit
*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
*> if INFO = 0, Z contains Q*Z.
*> Normally Q is the unitary matrix generated by ZUNGHR
*> after the call to ZGEHRD which formed the Hessenberg matrix
*> H. (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if COMPZ = 'I' or
*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, if INFO = 0, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient and delivers very good and sometimes
*> optimal performance. However, LWORK as large as 11*N
*> may be required for optimal performance. A workspace
*> query is recommended to determine the optimal workspace
*> size.
*>
*> If LWORK = -1, then ZHSEQR does a workspace query.
*> In this case, ZHSEQR checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .LT. 0: if INFO = -i, the i-th argument had an illegal
*> value
*> .GT. 0: if INFO = i, ZHSEQR failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and JOB = 'E', then on exit, the
*> remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and JOB = 'S', then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and COMPZ = 'V', then on exit
*>
*> (final value of Z) = (initial value of Z)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO .GT. 0 and COMPZ = 'I', then on exit
*> (final value of Z) = U
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO .GT. 0 and COMPZ = 'N', then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Default values supplied by
*> ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
*> It is suggested that these defaults be adjusted in order
*> to attain best performance in each particular
*> computational environment.
*>
*> ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
*> Default: 75. (Must be at least 11.)
*>
*> ISPEC=13: Recommended deflation window size.
*> This depends on ILO, IHI and NS. NS is the
*> number of simultaneous shifts returned
*> by ILAENV(ISPEC=15). (See ISPEC=15 below.)
*> The default for (IHI-ILO+1).LE.500 is NS.
*> The default for (IHI-ILO+1).GT.500 is 3*NS/2.
*>
*> ISPEC=14: Nibble crossover point. (See IPARMQ for
*> details.) Default: 14% of deflation window
*> size.
*>
*> ISPEC=15: Number of simultaneous shifts in a multishift
*> QR iteration.
*>
*> If IHI-ILO+1 is ...
*>
*> greater than ...but less ... the
*> or equal to ... than default is
*>
*> 1 30 NS = 2(+)
*> 30 60 NS = 4(+)
*> 60 150 NS = 10(+)
*> 150 590 NS = **
*> 590 3000 NS = 64
*> 3000 6000 NS = 128
*> 6000 infinity NS = 256
*>
*> (+) By default some or all matrices of this order
*> are passed to the implicit double shift routine
*> ZLAHQR and this parameter is ignored. See
*> ISPEC=12 above and comments in IPARMQ for
*> details.
*>
*> (**) The asterisks (**) indicate an ad-hoc
*> function of N increasing from 10 to 64.
*>
*> ISPEC=16: Select structured matrix multiply.
*> If the number of simultaneous shifts (specified
*> by ISPEC=15) is less than 14, then the default
*> for ISPEC=16 is 0. Otherwise the default for
*> ISPEC=16 is 2.
*> \endverbatim
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* =====================================================================
SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== NL allocates some local workspace to help small matrices
* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is
* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom-
* . mended. (The default value of NMIN is 75.) Using NL = 49
* . allows up to six simultaneous shifts and a 16-by-16
* . deflation window. ====
INTEGER NL
PARAMETER ( NL = 49 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0d0 )
* ..
* .. Local Arrays ..
COMPLEX*16 HL( NL, NL ), WORKL( NL )
* ..
* .. Local Scalars ..
INTEGER KBOT, NMIN
LOGICAL INITZ, LQUERY, WANTT, WANTZ
* ..
* .. External Functions ..
INTEGER ILAENV
LOGICAL LSAME
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, MAX, MIN
* ..
* .. Executable Statements ..
*
* ==== Decode and check the input parameters. ====
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO )
LQUERY = LWORK.EQ.-1
*
INFO = 0
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
*
* ==== Quick return in case of invalid argument. ====
*
CALL XERBLA( 'ZHSEQR', -INFO )
RETURN
*
ELSE IF( N.EQ.0 ) THEN
*
* ==== Quick return in case N = 0; nothing to do. ====
*
RETURN
*
ELSE IF( LQUERY ) THEN
*
* ==== Quick return in case of a workspace query ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
$ LDZ, WORK, LWORK, INFO )
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1,
$ N ) ) ), RZERO )
RETURN
*
ELSE
*
* ==== copy eigenvalues isolated by ZGEBAL ====
*
IF( ILO.GT.1 )
$ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 )
IF( IHI.LT.N )
$ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
*
* ==== Initialize Z, if requested ====
*
IF( INITZ )
$ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
* ==== Quick return if possible ====
*
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
$ ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
*
IF( N.GT.NMIN ) THEN
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, WORK, LWORK, INFO )
ELSE
*
* ==== Small matrix ====
*
CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, INFO )
*
IF( INFO.GT.0 ) THEN
*
* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds
* . when ZLAHQR fails. ====
*
KBOT = INFO
*
IF( N.GE.NL ) THEN
*
* ==== Larger matrices have enough subdiagonal scratch
* . space to call ZLAQR0 directly. ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
$ ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
ELSE
*
* ==== Tiny matrices don't have enough subdiagonal
* . scratch space to benefit from ZLAQR0. Hence,
* . tiny matrices must be copied into a larger
* . array before calling ZLAQR0. ====
*
CALL ZLACPY( 'A', N, N, H, LDH, HL, NL )
HL( N+1, N ) = ZERO
CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
$ NL )
CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
$ ILO, IHI, Z, LDZ, WORKL, NL, INFO )
IF( WANTT .OR. INFO.NE.0 )
$ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH )
END IF
END IF
END IF
*
* ==== Clear out the trash, if necessary. ====
*
IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
$ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
*
WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ),
$ DBLE( WORK( 1 ) ) ), RZERO )
END IF
*
* ==== End of ZHSEQR ====
*
END
*> \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLABRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
* LDY )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
* $ Y( LDY, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLABRD reduces the first NB rows and columns of a complex general
*> m by n matrix A to upper or lower real bidiagonal form by a unitary
*> transformation Q**H * A * P, and returns the matrices X and Y which
*> are needed to apply the transformation to the unreduced part of A.
*>
*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
*> bidiagonal form.
*>
*> This is an auxiliary routine called by ZGEBRD
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of leading rows and columns of A to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n general matrix to be reduced.
*> On exit, the first NB rows and columns of the matrix are
*> overwritten; the rest of the array is unchanged.
*> If m >= n, elements on and below the diagonal in the first NB
*> columns, with the array TAUQ, represent the unitary
*> matrix Q as a product of elementary reflectors; and
*> elements above the diagonal in the first NB rows, with the
*> array TAUP, represent the unitary matrix P as a product
*> of elementary reflectors.
*> If m < n, elements below the diagonal in the first NB
*> columns, with the array TAUQ, represent the unitary
*> matrix Q as a product of elementary reflectors, and
*> elements on and above the diagonal in the first NB rows,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (NB)
*> The diagonal elements of the first NB rows and columns of
*> the reduced matrix. D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (NB)
*> The off-diagonal elements of the first NB rows and columns of
*> the reduced matrix.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NB)
*> The m-by-nb matrix X required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,M).
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (LDY,NB)
*> The n-by-nb matrix Y required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*> LDY is INTEGER
*> The leading dimension of the array Y. LDY >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors.
*>
*> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
*> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The elements of the vectors v and u together form the m-by-nb matrix
*> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply
*> the transformation to the unreduced part of the matrix, using a block
*> update of the form: A := A - V*Y**H - X*U**H.
*>
*> The contents of A on exit are illustrated by the following examples
*> with nb = 2:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
*> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
*> ( v1 v2 a a a ) ( v1 1 a a a a )
*> ( v1 v2 a a a ) ( v1 v2 a a a a )
*> ( v1 v2 a a a ) ( v1 v2 a a a a )
*> ( v1 v2 a a a )
*>
*> where a denotes an element of the original matrix which is unchanged,
*> vi denotes an element of the vector defining H(i), and ui an element
*> of the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
$ LDY )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
$ Y( LDY, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, NB
*
* Update A(i:m,i)
*
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+1:m,i)
*
ALPHA = A( I, I )
CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = ALPHA
IF( I.LT.N ) THEN
A( I, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
$ A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
$ Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
$ A( I, 1 ), LDA, A( I, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
$ X( I, 1 ), LDX, A( I, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
$ Y( I+1, I ), 1 )
CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
*
* Update A(i,i+1:n)
*
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZLACGV( I, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
CALL ZLACGV( I, A( I, 1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
$ A( I, I+1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
*
* Generate reflection P(i) to annihilate A(i,i+2:n)
*
ALPHA = A( I, I+1 )
CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
$ TAUP( I ) )
E( I ) = ALPHA
A( I, I+1 ) = ONE
*
* Compute X(i+1:m,i)
*
CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
$ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
$ X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, NB
*
* Update A(i,i:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
$ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
$ LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
*
* Generate reflection P(i) to annihilate A(i,i+1:n)
*
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = ALPHA
IF( I.LT.M ) THEN
A( I, I ) = ONE
*
* Compute X(i+1:m,i)
*
CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
$ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
$ X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
CALL ZLACGV( N-I+1, A( I, I ), LDA )
*
* Update A(i+1:m,i)
*
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+2:m,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
$ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
$ Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
$ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
$ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
$ Y( I+1, I ), 1 )
CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
ELSE
CALL ZLACGV( N-I+1, A( I, I ), LDA )
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZLABRD
*
END
*> \brief \b ZLACGV conjugates a complex vector.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACGV( N, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACGV conjugates a complex vector of length N.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of the vector X. N >= 0.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-1)*abs(INCX))
*> On entry, the vector of length N to be conjugated.
*> On exit, X is overwritten with conjg(X).
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive elements of X.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACGV( N, X, INCX )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = DCONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = DCONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of ZLACGV
*
END
*> \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACN2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
*
* .. Scalar Arguments ..
* INTEGER KASE, N
* DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
* INTEGER ISAVE( 3 )
* COMPLEX*16 V( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACN2 estimates the 1-norm of a square, complex matrix A.
*> Reverse communication is used for evaluating matrix-vector products.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 1.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (N)
*> On the final return, V = A*W, where EST = norm(V)/norm(W)
*> (W is not returned).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> On an intermediate return, X should be overwritten by
*> A * X, if KASE=1,
*> A**H * X, if KASE=2,
*> where A**H is the conjugate transpose of A, and ZLACN2 must be
*> re-called with all the other parameters unchanged.
*> \endverbatim
*>
*> \param[in,out] EST
*> \verbatim
*> EST is DOUBLE PRECISION
*> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
*> unchanged from the previous call to ZLACN2.
*> On exit, EST is an estimate (a lower bound) for norm(A).
*> \endverbatim
*>
*> \param[in,out] KASE
*> \verbatim
*> KASE is INTEGER
*> On the initial call to ZLACN2, KASE should be 0.
*> On an intermediate return, KASE will be 1 or 2, indicating
*> whether X should be overwritten by A * X or A**H * X.
*> On the final return from ZLACN2, KASE will again be 0.
*> \endverbatim
*>
*> \param[in,out] ISAVE
*> \verbatim
*> ISAVE is INTEGER array, dimension (3)
*> ISAVE is used to save variables between calls to ZLACN2
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Originally named CONEST, dated March 16, 1988.
*>
*> Last modified: April, 1999
*>
*> This is a thread safe version of ZLACON, which uses the array ISAVE
*> in place of a SAVE statement, as follows:
*>
*> ZLACON ZLACN2
*> JUMP ISAVE(1)
*> J ISAVE(2)
*> ITER ISAVE(3)
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Nick Higham, University of Manchester
*
*> \par References:
* ================
*>
*> N.J. Higham, "FORTRAN codes for estimating the one-norm of
*> a real or complex matrix, with applications to condition estimation",
*> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*>
* =====================================================================
SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER KASE, N
DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
INTEGER ISAVE( 3 )
COMPLEX*16 V( * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
INTEGER I, JLAST
DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
* ..
* .. External Functions ..
INTEGER IZMAX1
DOUBLE PRECISION DLAMCH, DZSUM1
EXTERNAL IZMAX1, DLAMCH, DZSUM1
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'Safe minimum' )
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = DCMPLX( ONE / DBLE( N ) )
10 CONTINUE
KASE = 1
ISAVE( 1 ) = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 )
*
* ................ ENTRY (ISAVE( 1 ) = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 130
END IF
EST = DZSUM1( N, X, 1 )
*
DO 30 I = 1, N
ABSXI = ABS( X( I ) )
IF( ABSXI.GT.SAFMIN ) THEN
X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
$ DIMAG( X( I ) ) / ABSXI )
ELSE
X( I ) = CONE
END IF
30 CONTINUE
KASE = 2
ISAVE( 1 ) = 2
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
*
40 CONTINUE
ISAVE( 2 ) = IZMAX1( N, X, 1 )
ISAVE( 3 ) = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = CZERO
60 CONTINUE
X( ISAVE( 2 ) ) = CONE
KASE = 1
ISAVE( 1 ) = 3
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL ZCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = DZSUM1( N, V, 1 )
*
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 100
*
DO 80 I = 1, N
ABSXI = ABS( X( I ) )
IF( ABSXI.GT.SAFMIN ) THEN
X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
$ DIMAG( X( I ) ) / ABSXI )
ELSE
X( I ) = CONE
END IF
80 CONTINUE
KASE = 2
ISAVE( 1 ) = 4
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 4)
* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
*
90 CONTINUE
JLAST = ISAVE( 2 )
ISAVE( 2 ) = IZMAX1( N, X, 1 )
IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
$ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
ISAVE( 3 ) = ISAVE( 3 ) + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
100 CONTINUE
ALTSGN = ONE
DO 110 I = 1, N
X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) )
ALTSGN = -ALTSGN
110 CONTINUE
KASE = 1
ISAVE( 1 ) = 5
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
120 CONTINUE
TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL ZCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
130 CONTINUE
KASE = 0
RETURN
*
* End of ZLACN2
*
END
*> \brief \b ZLACPY copies all or part of one two-dimensional array to another.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACPY copies all or part of a two-dimensional matrix A to another
*> matrix B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be copied to B.
*> = 'U': Upper triangular part
*> = 'L': Lower triangular part
*> Otherwise: All of the matrix A
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A. If UPLO = 'U', only the upper trapezium
*> is accessed; if UPLO = 'L', only the lower trapezium is
*> accessed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> On exit, B = A in the locations specified by UPLO.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
*
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
RETURN
*
* End of ZLACPY
*
END
*> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* .. Scalar Arguments ..
* COMPLEX*16 X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX*16
*> The complex scalars X and Y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
COMPLEX*16 X, Y
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
$ ZI )
ZLADIV = DCMPLX( ZR, ZI )
*
RETURN
*
* End of ZLADIV
*
END
*> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHQR is an auxiliary routine called by CHSEQR to update the
*> eigenvalues and Schur decomposition already computed by CHSEQR, by
*> dealing with the Hessenberg submatrix in rows and columns ILO to
*> IHI.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> It is assumed that H is already upper triangular in rows and
*> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
*> ZLAHQR works primarily with the Hessenberg submatrix in rows
*> and columns ILO to IHI, but applies transformations to all of
*> H if WANTT is .TRUE..
*> 1 <= ILO <= max(1,IHI); IHI <= N.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO is zero and if WANTT is .TRUE., then H
*> is upper triangular in rows and columns ILO:IHI. If INFO
*> is zero and if WANTT is .FALSE., then the contents of H
*> are unspecified on exit. The output state of H in case
*> INF is positive is below under the description of INFO.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues ILO to IHI are stored in the
*> corresponding elements of W. If WANTT is .TRUE., the
*> eigenvalues are stored in the same order as on the diagonal
*> of the Schur form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If WANTZ is .TRUE., on entry Z must contain the current
*> matrix Z of transformations accumulated by CHSEQR, and on
*> exit Z has been updated; transformations are applied only to
*> the submatrix Z(ILOZ:IHIZ,ILO:IHI).
*> If WANTZ is .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .GT. 0: if INFO = i, ZLAHQR failed to compute all the
*> eigenvalues ILO to IHI in a total of 30 iterations
*> per eigenvalue; elements i+1:ihi of W contain
*> those eigenvalues which have been successfully
*> computed.
*>
*> If INFO .GT. 0 and WANTT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the
*> eigenvalues of the upper Hessenberg matrix
*> rows and columns ILO thorugh INFO of the final,
*> output value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*> (*) (initial value of H)*U = U*(final value of H)
*> where U is an orthognal matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*> (final value of Z) = (initial value of Z)*U
*> where U is the orthogonal matrix in (*)
*> (regardless of the value of WANTT.)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> 02-96 Based on modifications by
*> David Day, Sandia National Laboratory, USA
*>
*> 12-04 Further modifications by
*> Ralph Byers, University of Kansas, USA
*> This is a modified version of ZLAHQR from LAPACK version 3.0.
*> It is (1) more robust against overflow and underflow and
*> (2) adopts the more conservative Ahues & Tisseur stopping
*> criterion (LAWN 122, 1997).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
* =========================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 30 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE, HALF
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
DOUBLE PRECISION DAT1
PARAMETER ( DAT1 = 3.0d0 / 4.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
$ V2, X, Y
DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
$ SAFMIN, SMLNUM, SX, T2, TST, ULP
INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ
* ..
* .. Local Arrays ..
COMPLEX*16 V( 2 )
* ..
* .. External Functions ..
COMPLEX*16 ZLADIV
DOUBLE PRECISION DLAMCH
EXTERNAL ZLADIV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
* ==== clear out the trash ====
DO 10 J = ILO, IHI - 3
H( J+2, J ) = ZERO
H( J+3, J ) = ZERO
10 CONTINUE
IF( ILO.LE.IHI-2 )
$ H( IHI, IHI-2 ) = ZERO
* ==== ensure that subdiagonal entries are real ====
IF( WANTT ) THEN
JLO = 1
JHI = N
ELSE
JLO = ILO
JHI = IHI
END IF
DO 20 I = ILO + 1, IHI
IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
* ==== The following redundant normalization
* . avoids problems with both gradual and
* . sudden underflow in ABS(H(I,I-1)) ====
SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
SC = DCONJG( SC ) / ABS( SC )
H( I, I-1 ) = ABS( H( I, I-1 ) )
CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
$ H( JLO, I ), 1 )
IF( WANTZ )
$ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
END IF
20 CONTINUE
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
30 CONTINUE
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 splits off at the bottom because a
* subdiagonal element has become negligible.
*
L = ILO
DO 130 ITS = 0, ITMAX
*
* Look for a single small subdiagonal element.
*
DO 40 K = I, L + 1, -1
IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
$ GO TO 50
TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
IF( TST.EQ.ZERO ) THEN
IF( K-2.GE.ILO )
$ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
IF( K+1.LE.IHI )
$ TST = TST + ABS( DBLE( H( K+1, K ) ) )
END IF
* ==== The following is a conservative small subdiagonal
* . deflation criterion due to Ahues & Tisseur (LAWN 122,
* . 1997). It has better mathematical foundation and
* . improves accuracy in some examples. ====
IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
AA = MAX( CABS1( H( K, K ) ),
$ CABS1( H( K-1, K-1 )-H( K, K ) ) )
BB = MIN( CABS1( H( K, K ) ),
$ CABS1( H( K-1, K-1 )-H( K, K ) ) )
S = AA + AB
IF( BA*( AB / S ).LE.MAX( SMLNUM,
$ ULP*( BB*( AA / S ) ) ) )GO TO 50
END IF
40 CONTINUE
50 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 has split off.
*
IF( L.GE.I )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( L+1, L ) ) )
T = S + H( L, L )
ELSE IF( ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
T = S + H( I, I )
ELSE
*
* Wilkinson's shift.
*
T = H( I, I )
U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
S = CABS1( U )
IF( S.NE.RZERO ) THEN
X = HALF*( H( I-1, I-1 )-T )
SX = CABS1( X )
S = MAX( S, CABS1( X ) )
Y = S*SQRT( ( X / S )**2+( U / S )**2 )
IF( SX.GT.RZERO ) THEN
IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
$ DIMAG( Y ).LT.RZERO )Y = -Y
END IF
T = T - U*ZLADIV( U, ( X+Y ) )
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 60 M = I - 1, L + 1, -1
*
* Determine the effect of starting the single-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H11S = H11 - T
H21 = DBLE( H( M+1, M ) )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
H10 = DBLE( H( M, M-1 ) )
IF( ABS( H10 )*ABS( H21 ).LE.ULP*
$ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
$ GO TO 70
60 CONTINUE
H11 = H( L, L )
H22 = H( L+1, L+1 )
H11S = H11 - T
H21 = DBLE( H( L+1, L ) )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
70 CONTINUE
*
* Single-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix.
*
* V(2) is always real before the call to ZLARFG, and hence
* after the call T2 ( = T1*V(2) ) is also real.
*
IF( K.GT.M )
$ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
END IF
V2 = V( 2 )
T2 = DBLE( T1*V2 )
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 80 J = K, I2
SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM
H( K+1, J ) = H( K+1, J ) - SUM*V2
80 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+2,I).
*
DO 90 J = I1, MIN( K+2, I )
SUM = T1*H( J, K ) + T2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM
H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
90 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 100 J = ILOZ, IHIZ
SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM
Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
100 CONTINUE
END IF
*
IF( K.EQ.M .AND. M.GT.L ) THEN
*
* If the QR step was started at row M > L because two
* consecutive small subdiagonals were found, then extra
* scaling must be performed to ensure that H(M,M-1) remains
* real.
*
TEMP = ONE - T1
TEMP = TEMP / ABS( TEMP )
H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
IF( M+2.LE.I )
$ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
DO 110 J = M, I
IF( J.NE.M+1 ) THEN
IF( I2.GT.J )
$ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
$ 1 )
END IF
END IF
110 CONTINUE
END IF
120 CONTINUE
*
* Ensure that H(I,I-1) is real.
*
TEMP = H( I, I-1 )
IF( DIMAG( TEMP ).NE.RZERO ) THEN
RTEMP = ABS( TEMP )
H( I, I-1 ) = RTEMP
TEMP = TEMP / RTEMP
IF( I2.GT.I )
$ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
END IF
END IF
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
W( I ) = H( I, I )
*
* return to start of the main loop with new value of I.
*
I = L - 1
GO TO 30
*
150 CONTINUE
RETURN
*
* End of ZLAHQR
*
END
*> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* .. Scalar Arguments ..
* INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
* $ Y( LDY, NB )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
*> matrix A so that elements below the k-th subdiagonal are zero. The
*> reduction is performed by an unitary similarity transformation
*> Q**H * A * Q. The routine returns the matrices V and T which determine
*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
*>
*> This is an auxiliary routine called by ZGEHRD.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The offset for the reduction. Elements below the k-th
*> subdiagonal in the first NB columns are reduced to zero.
*> K < N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of columns to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N-K+1)
*> On entry, the n-by-(n-k+1) general matrix A.
*> On exit, the elements on and above the k-th subdiagonal in
*> the first NB columns are overwritten with the corresponding
*> elements of the reduced matrix; the elements below the k-th
*> subdiagonal, with the array TAU, represent the matrix Q as a
*> product of elementary reflectors. The other columns of A are
*> unchanged. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors. See Further
*> Details.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NB)
*> The upper triangular matrix T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= NB.
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (LDY,NB)
*> The n-by-nb matrix Y.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*> LDY is INTEGER
*> The leading dimension of the array Y. LDY >= N.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of nb elementary reflectors
*>
*> Q = H(1) H(2) . . . H(nb).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
*> A(i+k+1:n,i), and tau in TAU(i).
*>
*> The elements of the vectors v together form the (n-k+1)-by-nb matrix
*> V which is needed, with T and Y, to apply the transformation to the
*> unreduced part of the matrix, using an update of the form:
*> A := (I - V*T*V**H) * (A - Y*V**H).
*>
*> The contents of A on exit are illustrated by the following example
*> with n = 7, k = 3 and nb = 2:
*>
*> ( a a a a a )
*> ( a a a a a )
*> ( a a a a a )
*> ( h h a a a )
*> ( v1 h a a a )
*> ( v1 v2 a a a )
*> ( v1 v2 a a a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*>
*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD
*> incorporating improvements proposed by Quintana-Orti and Van de
*> Gejin. Note that the entries of A(1:K,2:NB) differ from those
*> returned by the original LAPACK-3.0's DLAHRD routine. (This
*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
*> \endverbatim
*
*> \par References:
* ================
*>
*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the
*> performance of reduction to Hessenberg form," ACM Transactions on
*> Mathematical Software, 32(2):180-194, June 2006.
*>
* =====================================================================
SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 EI
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY,
$ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(K+1:N,I)
*
* Update I-th column of A - Y * V**H
*
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
*
* Apply I - V * T**H * V**H to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1**H * b1
*
CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT',
$ I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2**H * b2
*
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T**H * w
*
CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
$ A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL ZTRMV( 'Lower', 'NO TRANSPOSE',
$ 'UNIT', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(I) to annihilate
* A(K+I+1:N,I)
*
CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(K+1:N,I)
*
CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
$ ONE, A( K+1, I+1 ),
$ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
$ Y( K+1, 1 ), LDY,
$ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
*
* Compute T(1:I,I)
*
CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
* Compute Y(1:K,1:NB)
*
CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
$ 'UNIT', K, NB,
$ ONE, A( K+1, 1 ), LDA, Y, LDY )
IF( N.GT.K+NB )
$ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
$ NB, N-K-NB, ONE,
$ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
$ LDY )
CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
$ 'NON-UNIT', K, NB,
$ ONE, T, LDT, Y, LDY )
*
RETURN
*
* End of ZLAHR2
*
END
*> \brief \b ZLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below the k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* .. Scalar Arguments ..
* INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
* $ Y( LDY, NB )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
*> matrix A so that elements below the k-th subdiagonal are zero. The
*> reduction is performed by a unitary similarity transformation
*> Q**H * A * Q. The routine returns the matrices V and T which determine
*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
*>
*> This is an OBSOLETE auxiliary routine.
*> This routine will be 'deprecated' in a future release.
*> Please use the new routine ZLAHR2 instead.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The offset for the reduction. Elements below the k-th
*> subdiagonal in the first NB columns are reduced to zero.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of columns to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N-K+1)
*> On entry, the n-by-(n-k+1) general matrix A.
*> On exit, the elements on and above the k-th subdiagonal in
*> the first NB columns are overwritten with the corresponding
*> elements of the reduced matrix; the elements below the k-th
*> subdiagonal, with the array TAU, represent the matrix Q as a
*> product of elementary reflectors. The other columns of A are
*> unchanged. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors. See Further
*> Details.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NB)
*> The upper triangular matrix T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= NB.
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (LDY,NB)
*> The n-by-nb matrix Y.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*> LDY is INTEGER
*> The leading dimension of the array Y. LDY >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of nb elementary reflectors
*>
*> Q = H(1) H(2) . . . H(nb).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
*> A(i+k+1:n,i), and tau in TAU(i).
*>
*> The elements of the vectors v together form the (n-k+1)-by-nb matrix
*> V which is needed, with T and Y, to apply the transformation to the
*> unreduced part of the matrix, using an update of the form:
*> A := (I - V*T*V**H) * (A - Y*V**H).
*>
*> The contents of A on exit are illustrated by the following example
*> with n = 7, k = 3 and nb = 2:
*>
*> ( a h a a a )
*> ( a h a a a )
*> ( a h a a a )
*> ( h h a a a )
*> ( v1 h a a a )
*> ( v1 v2 a a a )
*> ( v1 v2 a a a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 EI
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZLACGV, ZLARFG, ZSCAL,
$ ZTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(1:n,i)
*
* Compute i-th column of A - Y * V**H
*
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
*
* Apply I - V * T**H * V**H to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1**H * b1
*
CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL ZTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
*
* w := w + V2**H *b2
*
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
$ A( K+I, 1 ), LDA, A( K+I, I ), 1, ONE,
$ T( 1, NB ), 1 )
*
* w := T**H *w
*
CALL ZTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1,
$ T, LDT, T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL ZGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL ZTRMV( 'Lower', 'No transpose', 'Unit', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(i) to annihilate
* A(k+i+1:n,i)
*
EI = A( K+I, I )
CALL ZLARFG( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
A( K+I, I ) = ONE
*
* Compute Y(1:n,i)
*
CALL ZGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
$ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
$ A( K+I, 1 ), LDA, A( K+I, I ), 1, ZERO, T( 1, I ),
$ 1 )
CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
$ ONE, Y( 1, I ), 1 )
CALL ZSCAL( N, TAU( I ), Y( 1, I ), 1 )
*
* Compute T(1:i,i)
*
CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
RETURN
*
* End of ZLAHRD
*
END
*> \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANGE returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> complex matrix A.
*> \endverbatim
*>
*> \return ZLANGE
*> \verbatim
*>
*> ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANGE as described
*> above.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0. When M = 0,
*> ZLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0. When N = 0,
*> ZLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(M,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*> referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GEauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
TEMP = ABS( A( I, J ) )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
TEMP = WORK( I )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANGE = VALUE
RETURN
*
* End of ZLANGE
*
END
*> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHE returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> complex hermitian matrix A.
*> \endverbatim
*>
*> \return ZLANHE
*> \verbatim
*>
*> ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANHE as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> hermitian matrix A is to be referenced.
*> = 'U': Upper triangular part of A is referenced
*> = 'L': Lower triangular part of A is referenced
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHE is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The hermitian matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of A contains the upper triangular part
*> of the matrix A, and the strictly lower triangular part of A
*> is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of A contains the lower triangular part of
*> the matrix A, and the strictly upper triangular part of A is
*> not referenced. Note that the imaginary parts of the diagonal
*> elements need not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(N,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16HEauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
DO 40 J = 1, N
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = J + 1, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
DO 130 I = 1, N
IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( A( I, I ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHE = VALUE
RETURN
*
* End of ZLANHE
*
END
*> \brief \b ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHS returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> Hessenberg matrix A.
*> \endverbatim
*>
*> \return ZLANHS
*> \verbatim
*>
*> ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANHS as described
*> above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHS is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The n by n upper Hessenberg matrix A; the part of A below the
*> first sub-diagonal is not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(N,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I'; otherwise, WORK is not
*> referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, MIN( N, J+1 )
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, MIN( N, J+1 )
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, N
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, MIN( N, J+1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHS = VALUE
RETURN
*
* End of ZLANHS
*
END
*> \brief \b ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
* WORK )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORM, UPLO
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANTR returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> trapezoidal or triangular matrix A.
*> \endverbatim
*>
*> \return ZLANTR
*> \verbatim
*>
*> ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANTR as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower trapezoidal.
*> = 'U': Upper trapezoidal
*> = 'L': Lower trapezoidal
*> Note that A is triangular instead of trapezoidal if M = N.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A has unit diagonal.
*> = 'N': Non-unit diagonal
*> = 'U': Unit diagonal
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0, and if
*> UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0, and if
*> UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The trapezoidal matrix A (A is triangular if M = N).
*> If UPLO = 'U', the leading m by n upper trapezoidal part of
*> the array A contains the upper trapezoidal matrix, and the
*> strictly lower triangular part of A is not referenced.
*> If UPLO = 'L', the leading m by n lower trapezoidal part of
*> the array A contains the lower trapezoidal matrix, and the
*> strictly upper triangular part of A is not referenced. Note
*> that when DIAG = 'U', the diagonal elements of A are not
*> referenced and are assumed to be one.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(M,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*> referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( M, J-1 )
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J + 1, M
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = 1, MIN( M, J )
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = J, M
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
SUM = ONE
DO 90 I = 1, J - 1
SUM = SUM + ABS( A( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = 1, MIN( M, J )
SUM = SUM + ABS( A( I, J ) )
100 CONTINUE
END IF
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
110 CONTINUE
ELSE
DO 140 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 120 I = J + 1, M
SUM = SUM + ABS( A( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = J, M
SUM = SUM + ABS( A( I, J ) )
130 CONTINUE
END IF
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, M
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, MIN( M, J-1 )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, M
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, MIN( M, J )
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 220 I = N + 1, M
WORK( I ) = ZERO
220 CONTINUE
DO 240 J = 1, N
DO 230 I = J + 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
230 CONTINUE
240 CONTINUE
ELSE
DO 250 I = 1, M
WORK( I ) = ZERO
250 CONTINUE
DO 270 J = 1, N
DO 260 I = J, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
260 CONTINUE
270 CONTINUE
END IF
END IF
VALUE = ZERO
DO 280 I = 1, M
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
280 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 290 J = 2, N
CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
290 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 300 J = 1, N
CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
300 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = MIN( M, N )
DO 310 J = 1, N
CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
$ SUM )
310 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
DO 320 J = 1, N
CALL ZLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
320 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANTR = VALUE
RETURN
*
* End of ZLANTR
*
END
*> \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQP2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
* WORK )
*
* .. Scalar Arguments ..
* INTEGER LDA, M, N, OFFSET
* ..
* .. Array Arguments ..
* INTEGER JPVT( * )
* DOUBLE PRECISION VN1( * ), VN2( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQP2 computes a QR factorization with column pivoting of
*> the block A(OFFSET+1:M,1:N).
*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] OFFSET
*> \verbatim
*> OFFSET is INTEGER
*> The number of rows of the matrix A that must be pivoted
*> but no factorized. OFFSET >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
*> the triangular factor obtained; the elements in block
*> A(OFFSET+1:M,1:N) below the diagonal, together with the
*> array TAU, represent the orthogonal matrix Q as a product of
*> elementary reflectors. Block A(1:OFFSET,1:N) has been
*> accordingly pivoted, but no factorized.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] JPVT
*> \verbatim
*> JPVT is INTEGER array, dimension (N)
*> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
*> to the front of A*P (a leading column); if JPVT(i) = 0,
*> the i-th column of A is a free column.
*> On exit, if JPVT(i) = k, then the i-th column of A*P
*> was the k-th column of A.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[in,out] VN1
*> \verbatim
*> VN1 is DOUBLE PRECISION array, dimension (N)
*> The vector with the partial column norms.
*> \endverbatim
*>
*> \param[in,out] VN2
*> \verbatim
*> VN2 is DOUBLE PRECISION array, dimension (N)
*> The vector with the exact column norms.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*> X. Sun, Computer Science Dept., Duke University, USA
*> \n
*> Partial column norm updating strategy modified on April 2011
*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
*> University of Zagreb, Croatia.
*
*> \par References:
* ================
*>
*> LAPACK Working Note 176
*
*> \htmlonly
*> [PDF]
*> \endhtmlonly
*
* =====================================================================
SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER LDA, M, N, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION VN1( * ), VN2( * )
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
COMPLEX*16 CONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, ITEMP, J, MN, OFFPI, PVT
DOUBLE PRECISION TEMP, TEMP2, TOL3Z
COMPLEX*16 AII
* ..
* .. External Subroutines ..
EXTERNAL ZLARF, ZLARFG, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DCONJG, MAX, MIN, SQRT
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DZNRM2
EXTERNAL IDAMAX, DLAMCH, DZNRM2
* ..
* .. Executable Statements ..
*
MN = MIN( M-OFFSET, N )
TOL3Z = SQRT(DLAMCH('Epsilon'))
*
* Compute factorization.
*
DO 20 I = 1, MN
*
OFFPI = OFFSET + I
*
* Determine ith pivot column and swap if necessary.
*
PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
*
IF( PVT.NE.I ) THEN
CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
ITEMP = JPVT( PVT )
JPVT( PVT ) = JPVT( I )
JPVT( I ) = ITEMP
VN1( PVT ) = VN1( I )
VN2( PVT ) = VN2( I )
END IF
*
* Generate elementary reflector H(i).
*
IF( OFFPI.LT.M ) THEN
CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
$ TAU( I ) )
ELSE
CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
END IF
*
IF( I.LT.N ) THEN
*
* Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
*
AII = A( OFFPI, I )
A( OFFPI, I ) = CONE
CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
$ DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
$ WORK( 1 ) )
A( OFFPI, I ) = AII
END IF
*
* Update partial column norms.
*
DO 10 J = I + 1, N
IF( VN1( J ).NE.ZERO ) THEN
*
* NOTE: The following 4 lines follow from the analysis in
* Lapack Working Note 176.
*
TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
TEMP = MAX( TEMP, ZERO )
TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
IF( TEMP2 .LE. TOL3Z ) THEN
IF( OFFPI.LT.M ) THEN
VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
VN2( J ) = VN1( J )
ELSE
VN1( J ) = ZERO
VN2( J ) = ZERO
END IF
ELSE
VN1( J ) = VN1( J )*SQRT( TEMP )
END IF
END IF
10 CONTINUE
*
20 CONTINUE
*
RETURN
*
* End of ZLAQP2
*
END
*> \brief \b ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQPS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
* VN2, AUXV, F, LDF )
*
* .. Scalar Arguments ..
* INTEGER KB, LDA, LDF, M, N, NB, OFFSET
* ..
* .. Array Arguments ..
* INTEGER JPVT( * )
* DOUBLE PRECISION VN1( * ), VN2( * )
* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQPS computes a step of QR factorization with column pivoting
*> of a complex M-by-N matrix A by using Blas-3. It tries to factorize
*> NB columns from A starting from the row OFFSET+1, and updates all
*> of the matrix with Blas-3 xGEMM.
*>
*> In some cases, due to catastrophic cancellations, it cannot
*> factorize NB columns. Hence, the actual number of factorized
*> columns is returned in KB.
*>
*> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0
*> \endverbatim
*>
*> \param[in] OFFSET
*> \verbatim
*> OFFSET is INTEGER
*> The number of rows of A that have been factorized in
*> previous steps.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of columns to factorize.
*> \endverbatim
*>
*> \param[out] KB
*> \verbatim
*> KB is INTEGER
*> The number of columns actually factorized.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, block A(OFFSET+1:M,1:KB) is the triangular
*> factor obtained and block A(1:OFFSET,1:N) has been
*> accordingly pivoted, but no factorized.
*> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
*> been updated.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] JPVT
*> \verbatim
*> JPVT is INTEGER array, dimension (N)
*> JPVT(I) = K <==> Column K of the full matrix A has been
*> permuted into position I in AP.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (KB)
*> The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[in,out] VN1
*> \verbatim
*> VN1 is DOUBLE PRECISION array, dimension (N)
*> The vector with the partial column norms.
*> \endverbatim
*>
*> \param[in,out] VN2
*> \verbatim
*> VN2 is DOUBLE PRECISION array, dimension (N)
*> The vector with the exact column norms.
*> \endverbatim
*>
*> \param[in,out] AUXV
*> \verbatim
*> AUXV is COMPLEX*16 array, dimension (NB)
*> Auxiliar vector.
*> \endverbatim
*>
*> \param[in,out] F
*> \verbatim
*> F is COMPLEX*16 array, dimension (LDF,NB)
*> Matrix F**H = L * Y**H * A.
*> \endverbatim
*>
*> \param[in] LDF
*> \verbatim
*> LDF is INTEGER
*> The leading dimension of the array F. LDF >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*> X. Sun, Computer Science Dept., Duke University, USA
*> \n
*> Partial column norm updating strategy modified on April 2011
*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
*> University of Zagreb, Croatia.
*
*> \par References:
* ================
*>
*> LAPACK Working Note 176
*
*> \htmlonly
*> [PDF]
*> \endhtmlonly
*
* =====================================================================
SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
$ VN2, AUXV, F, LDF )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER KB, LDA, LDF, M, N, NB, OFFSET
* ..
* .. Array Arguments ..
INTEGER JPVT( * )
DOUBLE PRECISION VN1( * ), VN2( * )
COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
COMPLEX*16 CZERO, CONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
$ CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
DOUBLE PRECISION TEMP, TEMP2, TOL3Z
COMPLEX*16 AKK
* ..
* .. External Subroutines ..
EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DZNRM2
EXTERNAL IDAMAX, DLAMCH, DZNRM2
* ..
* .. Executable Statements ..
*
LASTRK = MIN( M, N+OFFSET )
LSTICC = 0
K = 0
TOL3Z = SQRT(DLAMCH('Epsilon'))
*
* Beginning of while loop.
*
10 CONTINUE
IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
K = K + 1
RK = OFFSET + K
*
* Determine ith pivot column and swap if necessary
*
PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
IF( PVT.NE.K ) THEN
CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
ITEMP = JPVT( PVT )
JPVT( PVT ) = JPVT( K )
JPVT( K ) = ITEMP
VN1( PVT ) = VN1( K )
VN2( PVT ) = VN2( K )
END IF
*
* Apply previous Householder reflectors to column K:
* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H.
*
IF( K.GT.1 ) THEN
DO 20 J = 1, K - 1
F( K, J ) = DCONJG( F( K, J ) )
20 CONTINUE
CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ),
$ LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 )
DO 30 J = 1, K - 1
F( K, J ) = DCONJG( F( K, J ) )
30 CONTINUE
END IF
*
* Generate elementary reflector H(k).
*
IF( RK.LT.M ) THEN
CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
ELSE
CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
END IF
*
AKK = A( RK, K )
A( RK, K ) = CONE
*
* Compute Kth column of F:
*
* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K).
*
IF( K.LT.N ) THEN
CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ),
$ A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO,
$ F( K+1, K ), 1 )
END IF
*
* Padding F(1:K,K) with zeros.
*
DO 40 J = 1, K
F( J, K ) = CZERO
40 CONTINUE
*
* Incremental updating of F:
* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H
* *A(RK:M,K).
*
IF( K.GT.1 ) THEN
CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ),
$ A( RK, 1 ), LDA, A( RK, K ), 1, CZERO,
$ AUXV( 1 ), 1 )
*
CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF,
$ AUXV( 1 ), 1, CONE, F( 1, K ), 1 )
END IF
*
* Update the current row of A:
* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H.
*
IF( K.LT.N ) THEN
CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K,
$ K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF,
$ CONE, A( RK, K+1 ), LDA )
END IF
*
* Update partial column norms.
*
IF( RK.LT.LASTRK ) THEN
DO 50 J = K + 1, N
IF( VN1( J ).NE.ZERO ) THEN
*
* NOTE: The following 4 lines follow from the analysis in
* Lapack Working Note 176.
*
TEMP = ABS( A( RK, J ) ) / VN1( J )
TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
IF( TEMP2 .LE. TOL3Z ) THEN
VN2( J ) = DBLE( LSTICC )
LSTICC = J
ELSE
VN1( J ) = VN1( J )*SQRT( TEMP )
END IF
END IF
50 CONTINUE
END IF
*
A( RK, K ) = AKK
*
* End of while loop.
*
GO TO 10
END IF
KB = K
RK = OFFSET + KB
*
* Apply the block reflector to the rest of the matrix:
* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H.
*
IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB,
$ KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF,
$ CONE, A( RK+1, KB+1 ), LDA )
END IF
*
* Recomputation of difficult columns.
*
60 CONTINUE
IF( LSTICC.GT.0 ) THEN
ITEMP = NINT( VN2( LSTICC ) )
VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 1 )
*
* NOTE: The computation of VN1( LSTICC ) relies on the fact that
* SNRM2 does not fail on vectors with norm below the value of
* SQRT(DLAMCH('S'))
*
VN2( LSTICC ) = VN1( LSTICC )
LSTICC = ITEMP
GO TO 60
END IF
*
RETURN
*
* End of ZLAQPS
*
END
*> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR0 computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO.GT.0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR0 does a workspace query.
*> In this case, ZLAQR0 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .GT. 0: if INFO = i, ZLAQR0 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by varying the size of the
* . deflation window after KEXNW iterations. ====
INTEGER KEXNW
PARAMETER ( KEXNW = 5 )
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . ====
INTEGER KEXSH
PARAMETER ( KEXSH = 6 )
*
* ==== The constant WILK1 is used to form the exceptional
* . shifts. ====
DOUBLE PRECISION WILK1
PARAMETER ( WILK1 = 0.75d0 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
DOUBLE PRECISION S
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
$ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
LOGICAL SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
COMPLEX*16 ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
$ SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
IF( N.LE.NTINY ) THEN
*
* ==== Tiny matrices must use ZLAHQR. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to ZLAQR3 ====
*
CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
$ LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
NW = NWMAX
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 70 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 80
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size:
* . Typical Case:
* . If possible and advisable, nibble the entire
* . active block. If not, use size MIN(NWR,NWMAX)
* . or MIN(NWR+1,NWMAX) depending upon which has
* . the smaller corresponding subdiagonal entry
* . (a heuristic).
* .
* . Exceptional Case:
* . If there have been no deflations in KEXNW or
* . more iterations, then vary the deflation window
* . size. At first, because, larger windows are,
* . in general, more powerful than smaller ones,
* . rapidly increase the window to the maximum possible.
* . Then, gradually reduce the window size. ====
*
NH = KBOT - KTOP + 1
NWUPBD = MIN( NH, NWMAX )
IF( NDFL.LT.KEXNW ) THEN
NW = MIN( NWUPBD, NWR )
ELSE
NW = MIN( NWUPBD, 2*NW )
END IF
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
$ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
IF( NDFL.LT.KEXNW ) THEN
NDEC = -1
ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
NDEC = NDEC + 1
IF( NW-NDEC.LT.2 )
$ NDEC = 0
NW = NW - NDEC
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
$ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
$ LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if ZLAQR3
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . ZLAQR3 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, KS + 1, -2
W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
W( I-1 ) = W( I )
30 CONTINUE
ELSE
*
* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or
* . ZLAHQR on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
IF( NS.GT.NMIN ) THEN
CALL ZLAQR4( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1,
$ ZDUM, 1, WORK, LWORK, INF )
ELSE
CALL ZLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1,
$ ZDUM, 1, INF )
END IF
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. Scale to avoid
* . overflows, underflows and subnormals.
* . (The scale factor S can not be zero,
* . because H(KBOT,KBOT-1) is nonzero.) ====
*
IF( KS.GE.KBOT ) THEN
S = CABS1( H( KBOT-1, KBOT-1 ) ) +
$ CABS1( H( KBOT, KBOT-1 ) ) +
$ CABS1( H( KBOT-1, KBOT ) ) +
$ CABS1( H( KBOT, KBOT ) )
AA = H( KBOT-1, KBOT-1 ) / S
CC = H( KBOT, KBOT-1 ) / S
BB = H( KBOT-1, KBOT ) / S
DD = H( KBOT, KBOT ) / S
TR2 = ( AA+DD ) / TWO
DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
RTDISC = SQRT( -DET )
W( KBOT-1 ) = ( TR2+RTDISC )*S
W( KBOT ) = ( TR2-RTDISC )*S
*
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little) ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
$ THEN
SORTED = .false.
SWAP = W( I )
W( I ) = W( I+1 )
W( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
END IF
*
* ==== If there are only two shifts, then use
* . only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
$ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
W( KBOT-1 ) = W( KBOT )
ELSE
W( KBOT ) = W( KBOT-1 )
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR0 ====
*
END
*> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
*
* .. Scalar Arguments ..
* COMPLEX*16 S1, S2
* INTEGER LDH, N
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), V( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a
*> scalar multiple of the first column of the product
*>
*> (*) K = (H - s1*I)*(H - s2*I)
*>
*> scaling to avoid overflows and most underflows.
*>
*> This is useful for starting double implicit shift bulges
*> in the QR algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is integer
*> Order of the matrix H. N must be either 2 or 3.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*> H is COMPLEX*16 array of dimension (LDH,N)
*> The 2-by-2 or 3-by-3 matrix H in (*).
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is integer
*> The leading dimension of H as declared in
*> the calling procedure. LDH.GE.N
*> \endverbatim
*>
*> \param[in] S1
*> \verbatim
*> S1 is COMPLEX*16
*> \endverbatim
*>
*> \param[in] S2
*> \verbatim
*> S2 is COMPLEX*16
*>
*> S1 and S2 are the shifts defining K in (*) above.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array of dimension N
*> A scalar multiple of the first column of the
*> matrix K in (*).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
COMPLEX*16 S1, S2
INTEGER LDH, N
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), V( * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 CDUM, H21S, H31S
DOUBLE PRECISION S
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
IF( N.EQ.2 ) THEN
S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) )
IF( S.EQ.RZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )*
$ ( ( H( 1, 1 )-S2 ) / S )
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 )
END IF
ELSE
S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) +
$ CABS1( H( 3, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
V( 3 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
H31S = H( 3, 1 ) / S
V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) +
$ H( 1, 2 )*H21S + H( 1, 3 )*H31S
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S
V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 )
END IF
END IF
END
*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
* NV, WV, LDWV, WORK, LWORK )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR2 is identical to ZLAQR3 except that it avoids
*> recursion by calling ZLAHQR instead of ZLAQR4.
*>
*> Aggressive early deflation:
*>
*> ZLAQR2 accepts as input an upper Hessenberg matrix
*> H and performs an unitary similarity transformation
*> designed to detect and deflate fully converged eigenvalues from
*> a trailing principal submatrix. On output H has been over-
*> written by a new Hessenberg matrix that is a perturbation of
*> an unitary similarity transformation of H. It is to be
*> hoped that the final version of H has many zero subdiagonal
*> entries.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> If .TRUE., then the Hessenberg matrix H is fully updated
*> so that the triangular Schur factor may be
*> computed (in cooperation with the calling subroutine).
*> If .FALSE., then only enough of H is updated to preserve
*> the eigenvalues.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> If .TRUE., then the unitary matrix Z is updated so
*> so that the unitary Schur factor may be computed
*> (in cooperation with the calling subroutine).
*> If .FALSE., then Z is not referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H and (if WANTZ is .TRUE.) the
*> order of the unitary matrix Z.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
*> KBOT and KTOP together determine an isolated block
*> along the diagonal of the Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> It is assumed without a check that either
*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
*> determine an isolated block along the diagonal of the
*> Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] NW
*> \verbatim
*> NW is INTEGER
*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is integer
*> Leading dimension of H just as declared in the calling
*> subroutine. N .LE. LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
*> If WANTZ is .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is integer
*> The leading dimension of Z just as declared in the
*> calling subroutine. 1 .LE. LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is integer
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is integer
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension KBOT
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is integer scalar
*> The leading dimension of V just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is integer scalar
*> The number of columns of T. NH.GE.NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is integer
*> The leading dimension of T just as declared in the
*> calling subroutine. NW .LE. LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is integer
*> The number of rows of work array WV available for
*> workspace. NV.GE.NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is integer
*> The leading dimension of W just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK.
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is integer
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR2
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
$ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 BETA, CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
$ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to ZGEHRD ====
*
CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZUNMHR ====
*
CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = JW + MAX( LWK1, LWK2 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
WORK( 1 ) = ONE
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SH( KWTOP ) = H( KWTOP, KWTOP )
NS = 1
ND = 0
IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
$ KWTOP ) ) ) ) THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, INFQR )
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
DO 10 KNT = INFQR + 1, JW
*
* ==== Small spike tip deflation test ====
*
FOO = CABS1( T( NS, NS ) )
IF( FOO.EQ.RZERO )
$ FOO = CABS1( S )
IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
$ THEN
*
* ==== One more converged eigenvalue ====
*
NS = NS - 1
ELSE
*
* ==== One undeflatable eigenvalue. Move it up out of the
* . way. (ZTREXC can not fail in this case.) ====
*
IFST = NS
CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
ILST = ILST + 1
END IF
10 CONTINUE
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting the diagonal of T improves accuracy for
* . graded matrices. ====
*
DO 30 I = INFQR + 1, NS
IFST = I
DO 20 J = I + 1, NS
IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
$ IFST = J
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
$ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
DO 40 I = INFQR + 1, JW
SH( KWTOP+I-1 ) = T( I, I )
40 CONTINUE
*
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL ZCOPY( NS, V, LDV, WORK, 1 )
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
BETA = WORK( 1 )
CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
$ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 60 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 70 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
70 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
80 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR2 ====
*
END
*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
* NV, WV, LDWV, WORK, LWORK )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Aggressive early deflation:
*>
*> ZLAQR3 accepts as input an upper Hessenberg matrix
*> H and performs an unitary similarity transformation
*> designed to detect and deflate fully converged eigenvalues from
*> a trailing principal submatrix. On output H has been over-
*> written by a new Hessenberg matrix that is a perturbation of
*> an unitary similarity transformation of H. It is to be
*> hoped that the final version of H has many zero subdiagonal
*> entries.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> If .TRUE., then the Hessenberg matrix H is fully updated
*> so that the triangular Schur factor may be
*> computed (in cooperation with the calling subroutine).
*> If .FALSE., then only enough of H is updated to preserve
*> the eigenvalues.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> If .TRUE., then the unitary matrix Z is updated so
*> so that the unitary Schur factor may be computed
*> (in cooperation with the calling subroutine).
*> If .FALSE., then Z is not referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H and (if WANTZ is .TRUE.) the
*> order of the unitary matrix Z.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
*> KBOT and KTOP together determine an isolated block
*> along the diagonal of the Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> It is assumed without a check that either
*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
*> determine an isolated block along the diagonal of the
*> Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] NW
*> \verbatim
*> NW is INTEGER
*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is integer
*> Leading dimension of H just as declared in the calling
*> subroutine. N .LE. LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
*> If WANTZ is .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is integer
*> The leading dimension of Z just as declared in the
*> calling subroutine. 1 .LE. LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is integer
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is integer
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension KBOT
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is integer scalar
*> The leading dimension of V just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is integer scalar
*> The number of columns of T. NH.GE.NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is integer
*> The leading dimension of T just as declared in the
*> calling subroutine. NW .LE. LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is integer
*> The number of rows of work array WV available for
*> workspace. NV.GE.NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is integer
*> The leading dimension of W just as declared in the
*> calling subroutine. NW .LE. LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK.
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is integer
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR3
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
$ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 BETA, CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
$ LWKOPT, NMIN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER ILAENV
EXTERNAL DLAMCH, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
$ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to ZGEHRD ====
*
CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZUNMHR ====
*
CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZLAQR4 ====
*
CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
$ LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
WORK( 1 ) = ONE
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SH( KWTOP ) = H( KWTOP, KWTOP )
NS = 1
ND = 0
IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
$ KWTOP ) ) ) ) THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, WORK, LWORK, INFQR )
ELSE
CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, INFQR )
END IF
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
DO 10 KNT = INFQR + 1, JW
*
* ==== Small spike tip deflation test ====
*
FOO = CABS1( T( NS, NS ) )
IF( FOO.EQ.RZERO )
$ FOO = CABS1( S )
IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
$ THEN
*
* ==== One more converged eigenvalue ====
*
NS = NS - 1
ELSE
*
* ==== One undeflatable eigenvalue. Move it up out of the
* . way. (ZTREXC can not fail in this case.) ====
*
IFST = NS
CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
ILST = ILST + 1
END IF
10 CONTINUE
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting the diagonal of T improves accuracy for
* . graded matrices. ====
*
DO 30 I = INFQR + 1, NS
IFST = I
DO 20 J = I + 1, NS
IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
$ IFST = J
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
$ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
DO 40 I = INFQR + 1, JW
SH( KWTOP+I-1 ) = T( I, I )
40 CONTINUE
*
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL ZCOPY( NS, V, LDV, WORK, 1 )
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
BETA = WORK( 1 )
CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
$ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 60 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 70 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
70 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
80 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR3 ====
*
END
*> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR4 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR4 implements one level of recursion for ZLAQR0.
*> It is a complete implementation of the small bulge multi-shift
*> QR algorithm. It may be called by ZLAQR0 and, for large enough
*> deflation window size, it may be called by ZLAQR3. This
*> subroutine is identical to ZLAQR0 except that it calls ZLAQR2
*> instead of ZLAQR3.
*>
*> ZLAQR4 computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N .GE. 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO.GT.0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH .GE. max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO.GT.0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK .GE. max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR4 does a workspace query.
*> In this case, ZLAQR4 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> .GT. 0: if INFO = i, ZLAQR4 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO .GT. 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO .GT. 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by varying the size of the
* . deflation window after KEXNW iterations. ====
INTEGER KEXNW
PARAMETER ( KEXNW = 5 )
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . ====
INTEGER KEXSH
PARAMETER ( KEXSH = 6 )
*
* ==== The constant WILK1 is used to form the exceptional
* . shifts. ====
DOUBLE PRECISION WILK1
PARAMETER ( WILK1 = 0.75d0 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
DOUBLE PRECISION S
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
$ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
LOGICAL SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
COMPLEX*16 ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
$ SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
IF( N.LE.NTINY ) THEN
*
* ==== Tiny matrices must use ZLAHQR. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to ZLAQR2 ====
*
CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
$ LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
NW = NWMAX
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 70 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 80
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size:
* . Typical Case:
* . If possible and advisable, nibble the entire
* . active block. If not, use size MIN(NWR,NWMAX)
* . or MIN(NWR+1,NWMAX) depending upon which has
* . the smaller corresponding subdiagonal entry
* . (a heuristic).
* .
* . Exceptional Case:
* . If there have been no deflations in KEXNW or
* . more iterations, then vary the deflation window
* . size. At first, because, larger windows are,
* . in general, more powerful than smaller ones,
* . rapidly increase the window to the maximum possible.
* . Then, gradually reduce the window size. ====
*
NH = KBOT - KTOP + 1
NWUPBD = MIN( NH, NWMAX )
IF( NDFL.LT.KEXNW ) THEN
NW = MIN( NWUPBD, NWR )
ELSE
NW = MIN( NWUPBD, 2*NW )
END IF
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
$ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
IF( NDFL.LT.KEXNW ) THEN
NDEC = -1
ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
NDEC = NDEC + 1
IF( NW-NDEC.LT.2 )
$ NDEC = 0
NW = NW - NDEC
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
$ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
$ LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if ZLAQR2
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . ZLAQR2 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, KS + 1, -2
W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
W( I-1 ) = W( I )
30 CONTINUE
ELSE
*
* ==== Got NS/2 or fewer shifts? Use ZLAHQR
* . on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
CALL ZLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM,
$ 1, INF )
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. Scale to avoid
* . overflows, underflows and subnormals.
* . (The scale factor S can not be zero,
* . because H(KBOT,KBOT-1) is nonzero.) ====
*
IF( KS.GE.KBOT ) THEN
S = CABS1( H( KBOT-1, KBOT-1 ) ) +
$ CABS1( H( KBOT, KBOT-1 ) ) +
$ CABS1( H( KBOT-1, KBOT ) ) +
$ CABS1( H( KBOT, KBOT ) )
AA = H( KBOT-1, KBOT-1 ) / S
CC = H( KBOT, KBOT-1 ) / S
BB = H( KBOT-1, KBOT ) / S
DD = H( KBOT, KBOT ) / S
TR2 = ( AA+DD ) / TWO
DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
RTDISC = SQRT( -DET )
W( KBOT-1 ) = ( TR2+RTDISC )*S
W( KBOT ) = ( TR2-RTDISC )*S
*
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little) ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
$ THEN
SORTED = .false.
SWAP = W( I )
W( I ) = W( I+1 )
W( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
END IF
*
* ==== If there are only two shifts, then use
* . only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
$ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
W( KBOT-1 ) = W( KBOT )
ELSE
W( KBOT ) = W( KBOT-1 )
END IF
END IF
*
* ==== Use up to NS of the the smallest magnatiude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR4 ====
*
END
*> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR5 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
* H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
* WV, LDWV, NH, WH, LDWH )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
* $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR5, called by ZLAQR0, performs a
*> single small-bulge multi-shift QR sweep.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is logical scalar
*> WANTT = .true. if the triangular Schur factor
*> is being computed. WANTT is set to .false. otherwise.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is logical scalar
*> WANTZ = .true. if the unitary Schur factor is being
*> computed. WANTZ is set to .false. otherwise.
*> \endverbatim
*>
*> \param[in] KACC22
*> \verbatim
*> KACC22 is integer with value 0, 1, or 2.
*> Specifies the computation mode of far-from-diagonal
*> orthogonal updates.
*> = 0: ZLAQR5 does not accumulate reflections and does not
*> use matrix-matrix multiply to update far-from-diagonal
*> matrix entries.
*> = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
*> multiply to update the far-from-diagonal matrix entries.
*> = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
*> multiply to update the far-from-diagonal matrix entries,
*> and takes advantage of 2-by-2 block structure during
*> matrix multiplies.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is integer scalar
*> N is the order of the Hessenberg matrix H upon which this
*> subroutine operates.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is integer scalar
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is integer scalar
*> These are the first and last rows and columns of an
*> isolated diagonal block upon which the QR sweep is to be
*> applied. It is assumed without a check that
*> either KTOP = 1 or H(KTOP,KTOP-1) = 0
*> and
*> either KBOT = N or H(KBOT+1,KBOT) = 0.
*> \endverbatim
*>
*> \param[in] NSHFTS
*> \verbatim
*> NSHFTS is integer scalar
*> NSHFTS gives the number of simultaneous shifts. NSHFTS
*> must be positive and even.
*> \endverbatim
*>
*> \param[in,out] S
*> \verbatim
*> S is COMPLEX*16 array of size (NSHFTS)
*> S contains the shifts of origin that define the multi-
*> shift QR sweep. On output S may be reordered.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array of size (LDH,N)
*> On input H contains a Hessenberg matrix. On output a
*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
*> to the isolated diagonal block in rows and columns KTOP
*> through KBOT.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is integer scalar
*> LDH is the leading dimension of H just as declared in the
*> calling procedure. LDH.GE.MAX(1,N).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array of size (LDZ,IHI)
*> If WANTZ = .TRUE., then the QR Sweep unitary
*> similarity transformation is accumulated into
*> Z(ILOZ:IHIZ,ILO:IHI) from the right.
*> If WANTZ = .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is integer scalar
*> LDA is the leading dimension of Z just as declared in
*> the calling procedure. LDZ.GE.N.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array of size (LDV,NSHFTS/2)
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is integer scalar
*> LDV is the leading dimension of V as declared in the
*> calling procedure. LDV.GE.3.
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*> U is COMPLEX*16 array of size
*> (LDU,3*NSHFTS-3)
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is integer scalar
*> LDU is the leading dimension of U just as declared in the
*> in the calling subroutine. LDU.GE.3*NSHFTS-3.
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is integer scalar
*> NH is the number of columns in array WH available for
*> workspace. NH.GE.1.
*> \endverbatim
*>
*> \param[out] WH
*> \verbatim
*> WH is COMPLEX*16 array of size (LDWH,NH)
*> \endverbatim
*>
*> \param[in] LDWH
*> \verbatim
*> LDWH is integer scalar
*> Leading dimension of WH just as declared in the
*> calling procedure. LDWH.GE.3*NSHFTS-3.
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is integer scalar
*> NV is the number of rows in WV agailable for workspace.
*> NV.GE.1.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array of size
*> (LDWV,3*NSHFTS-3)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is integer scalar
*> LDWV is the leading dimension of WV as declared in the
*> in the calling subroutine. LDWV.GE.NV.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
$ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
$ WV, LDWV, NH, WH, LDWH )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
$ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
$ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 ALPHA, BETA, CDUM, REFSUM
DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
$ SMLNUM, TST1, TST2, ULP
INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
$ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
$ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
$ NS, NU
LOGICAL ACCUM, BLK22, BMP22
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
*
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
* ..
* .. Local Arrays ..
COMPLEX*16 VT( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET,
$ ZTRMM
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== If there are no shifts, then there is nothing to do. ====
*
IF( NSHFTS.LT.2 )
$ RETURN
*
* ==== If the active block is empty or 1-by-1, then there
* . is nothing to do. ====
*
IF( KTOP.GE.KBOT )
$ RETURN
*
* ==== NSHFTS is supposed to be even, but if it is odd,
* . then simply reduce it by one. ====
*
NS = NSHFTS - MOD( NSHFTS, 2 )
*
* ==== Machine constants for deflation ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Use accumulated reflections to update far-from-diagonal
* . entries ? ====
*
ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
*
* ==== If so, exploit the 2-by-2 block structure? ====
*
BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
*
* ==== clear trash ====
*
IF( KTOP+2.LE.KBOT )
$ H( KTOP+2, KTOP ) = ZERO
*
* ==== NBMPS = number of 2-shift bulges in the chain ====
*
NBMPS = NS / 2
*
* ==== KDU = width of slab ====
*
KDU = 6*NBMPS - 3
*
* ==== Create and chase chains of NBMPS bulges ====
*
DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
NDCOL = INCOL + KDU
IF( ACCUM )
$ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
*
* ==== Near-the-diagonal bulge chase. The following loop
* . performs the near-the-diagonal part of a small bulge
* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
* . chunk extends from column INCOL to column NDCOL
* . (including both column INCOL and column NDCOL). The
* . following loop chases a 3*NBMPS column long chain of
* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
* . may be less than KTOP and and NDCOL may be greater than
* . KBOT indicating phantom columns from which to chase
* . bulges before they are actually introduced or to which
* . to chase bulges beyond column KBOT.) ====
*
DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
*
* ==== Bulges number MTOP to MBOT are active double implicit
* . shift bulges. There may or may not also be small
* . 2-by-2 bulge, if there is room. The inactive bulges
* . (if any) must wait until the active bulges have moved
* . down the diagonal to make room. The phantom matrix
* . paradigm described above helps keep track. ====
*
MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
$ ( KBOT-2 )
*
* ==== Generate reflections to chase the chain right
* . one column. (The minimum value of K is KTOP-1.) ====
*
DO 10 M = MTOP, MBOT
K = KRCOL + 3*( M-1 )
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
$ S( 2*M ), V( 1, M ) )
ALPHA = V( 1, M )
CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
ELSE
BETA = H( K+1, K )
V( 2, M ) = H( K+2, K )
V( 3, M ) = H( K+3, K )
CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
*
* ==== A Bulge may collapse because of vigilant
* . deflation or destructive underflow. In the
* . underflow case, try the two-small-subdiagonals
* . trick to try to reinflate the bulge. ====
*
IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE.
$ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN
*
* ==== Typical case: not collapsed (yet). ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Atypical case: collapsed. Attempt to
* . reintroduce ignoring H(K+1,K) and H(K+2,K).
* . If the fill resulting from the new
* . reflector is too large, then abandon it.
* . Otherwise, use the new one. ====
*
CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ),
$ S( 2*M ), VT )
ALPHA = VT( 1 )
CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = DCONJG( VT( 1 ) )*
$ ( H( K+1, K )+DCONJG( VT( 2 ) )*
$ H( K+2, K ) )
*
IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP*
$ ( CABS1( H( K, K ) )+CABS1( H( K+1,
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
*
* ==== Starting a new bulge here would
* . create non-negligible fill. Use
* . the old one with trepidation. ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Stating a new bulge here would
* . create only negligible fill.
* . Replace the old reflector with
* . the new one. ====
*
H( K+1, K ) = H( K+1, K ) - REFSUM
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 )
V( 2, M ) = VT( 2 )
V( 3, M ) = VT( 3 )
END IF
END IF
END IF
10 CONTINUE
*
* ==== Generate a 2-by-2 reflection, if needed. ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
$ S( 2*M22 ), V( 1, M22 ) )
BETA = V( 1, M22 )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
ELSE
BETA = H( K+1, K )
V( 2, M22 ) = H( K+2, K )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
END IF
END IF
*
* ==== Multiply H by reflections from the left ====
*
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
DO 30 J = MAX( KTOP, KRCOL ), JBOT
MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
DO 20 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = DCONJG( V( 1, M ) )*
$ ( H( K+1, J )+DCONJG( V( 2, M ) )*
$ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
20 CONTINUE
30 CONTINUE
IF( BMP22 ) THEN
K = KRCOL + 3*( M22-1 )
DO 40 J = MAX( K+1, KTOP ), JBOT
REFSUM = DCONJG( V( 1, M22 ) )*
$ ( H( K+1, J )+DCONJG( V( 2, M22 ) )*
$ H( K+2, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
40 CONTINUE
END IF
*
* ==== Multiply H by reflections from the right.
* . Delay filling in the last row until the
* . vigilant deflation check is complete. ====
*
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
DO 80 M = MTOP, MBOT
IF( V( 1, M ).NE.ZERO ) THEN
K = KRCOL + 3*( M-1 )
DO 50 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
$ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
H( J, K+3 ) = H( J, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
50 CONTINUE
*
IF( ACCUM ) THEN
*
* ==== Accumulate U. (If necessary, update Z later
* . with with an efficient matrix-matrix
* . multiply.) ====
*
KMS = K - INCOL
DO 60 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
$ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
U( J, KMS+3 ) = U( J, KMS+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
60 CONTINUE
ELSE IF( WANTZ ) THEN
*
* ==== U is not accumulated, so update Z
* . now by multiplying by reflections
* . from the right. ====
*
DO 70 J = ILOZ, IHIZ
REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
$ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
Z( J, K+3 ) = Z( J, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
70 CONTINUE
END IF
END IF
80 CONTINUE
*
* ==== Special case: 2-by-2 reflection (if needed) ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF ( V( 1, M22 ).NE.ZERO ) THEN
DO 90 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
$ H( J, K+2 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
90 CONTINUE
*
IF( ACCUM ) THEN
KMS = K - INCOL
DO 100 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M22 )*( U( J, KMS+1 )+
$ V( 2, M22 )*U( J, KMS+2 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
100 CONTINUE
ELSE IF( WANTZ ) THEN
DO 110 J = ILOZ, IHIZ
REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
$ Z( J, K+2 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
110 CONTINUE
END IF
END IF
END IF
*
* ==== Vigilant deflation check ====
*
MSTART = MTOP
IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
$ MSTART = MSTART + 1
MEND = MBOT
IF( BMP22 )
$ MEND = MEND + 1
IF( KRCOL.EQ.KBOT-2 )
$ MEND = MEND + 1
DO 120 M = MSTART, MEND
K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
*
* ==== The following convergence test requires that
* . the tradition small-compared-to-nearby-diagonals
* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
* . criteria both be satisfied. The latter improves
* . accuracy in some examples. Falling back on an
* . alternate convergence criterion when TST1 or TST2
* . is zero (as done here) is traditional but probably
* . unnecessary. ====
*
IF( H( K+1, K ).NE.ZERO ) THEN
TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
IF( TST1.EQ.RZERO ) THEN
IF( K.GE.KTOP+1 )
$ TST1 = TST1 + CABS1( H( K, K-1 ) )
IF( K.GE.KTOP+2 )
$ TST1 = TST1 + CABS1( H( K, K-2 ) )
IF( K.GE.KTOP+3 )
$ TST1 = TST1 + CABS1( H( K, K-3 ) )
IF( K.LE.KBOT-2 )
$ TST1 = TST1 + CABS1( H( K+2, K+1 ) )
IF( K.LE.KBOT-3 )
$ TST1 = TST1 + CABS1( H( K+3, K+1 ) )
IF( K.LE.KBOT-4 )
$ TST1 = TST1 + CABS1( H( K+4, K+1 ) )
END IF
IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
$ THEN
H12 = MAX( CABS1( H( K+1, K ) ),
$ CABS1( H( K, K+1 ) ) )
H21 = MIN( CABS1( H( K+1, K ) ),
$ CABS1( H( K, K+1 ) ) )
H11 = MAX( CABS1( H( K+1, K+1 ) ),
$ CABS1( H( K, K )-H( K+1, K+1 ) ) )
H22 = MIN( CABS1( H( K+1, K+1 ) ),
$ CABS1( H( K, K )-H( K+1, K+1 ) ) )
SCL = H11 + H12
TST2 = H22*( H11 / SCL )
*
IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE.
$ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
END IF
END IF
120 CONTINUE
*
* ==== Fill in the last row of each bulge. ====
*
MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
DO 130 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
H( K+4, K+1 ) = -REFSUM
H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
H( K+4, K+3 ) = H( K+4, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
130 CONTINUE
*
* ==== End of near-the-diagonal bulge chase. ====
*
140 CONTINUE
*
* ==== Use U (if accumulated) to update far-from-diagonal
* . entries in H. If required, use U to update Z as
* . well. ====
*
IF( ACCUM ) THEN
IF( WANTT ) THEN
JTOP = 1
JBOT = N
ELSE
JTOP = KTOP
JBOT = KBOT
END IF
IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
$ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
*
* ==== Updates not exploiting the 2-by-2 block
* . structure of U. K1 and NU keep track of
* . the location and size of U in the special
* . cases of introducing bulges and chasing
* . bulges off the bottom. In these special
* . cases and in case the number of shifts
* . is NS = 2, there is no 2-by-2 block
* . structure to exploit. ====
*
K1 = MAX( 1, KTOP-INCOL )
NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
*
* ==== Horizontal Multiply ====
*
DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
$ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
$ LDWH )
CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH,
$ H( INCOL+K1, JCOL ), LDH )
150 CONTINUE
*
* ==== Vertical multiply ====
*
DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ H( JROW, INCOL+K1 ), LDH )
160 CONTINUE
*
* ==== Z multiply (also vertical) ====
*
IF( WANTZ ) THEN
DO 170 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ Z( JROW, INCOL+K1 ), LDZ )
170 CONTINUE
END IF
ELSE
*
* ==== Updates exploiting U's 2-by-2 block structure.
* . (I2, I4, J2, J4 are the last rows and columns
* . of the blocks.) ====
*
I2 = ( KDU+1 ) / 2
I4 = KDU
J2 = I4 - I2
J4 = KDU
*
* ==== KZS and KNZ deal with the band of zeros
* . along the diagonal of one of the triangular
* . blocks. ====
*
KZS = ( J4-J2 ) - ( NS+1 )
KNZ = NS + 1
*
* ==== Horizontal multiply ====
*
DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
*
* ==== Copy bottom of H to top+KZS of scratch ====
* (The first KZS rows get multiplied by zero.) ====
*
CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
$ LDH, WH( KZS+1, 1 ), LDWH )
*
* ==== Multiply by U21**H ====
*
CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
$ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
$ LDWH )
*
* ==== Multiply top of H by U11**H ====
*
CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
$ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
*
* ==== Copy top of H to bottom of WH ====
*
CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U21**H ====
*
CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
$ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
$ U( J2+1, I2+1 ), LDU,
$ H( INCOL+1+J2, JCOL ), LDH, ONE,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Copy it back ====
*
CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH,
$ H( INCOL+1, JCOL ), LDH )
180 CONTINUE
*
* ==== Vertical multiply ====
*
DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
*
* ==== Copy right of H to scratch (the first KZS
* . columns get multiplied by zero) ====
*
CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
$ LDH, WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
$ LDWV )
*
* ==== Copy left of H to right of scratch ====
*
CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ H( JROW, INCOL+1+J2 ), LDH,
$ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Copy it back ====
*
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ H( JROW, INCOL+1 ), LDH )
190 CONTINUE
*
* ==== Multiply Z (also vertical) ====
*
IF( WANTZ ) THEN
DO 200 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
*
* ==== Copy right of Z to left of scratch (first
* . KZS columns get multiplied by zero) ====
*
CALL ZLACPY( 'ALL', JLEN, KNZ,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U12 ====
*
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
$ LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
$ WV, LDWV )
*
* ==== Copy left of Z to right of scratch ====
*
CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
$ LDZ, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ U( J2+1, I2+1 ), LDU, ONE,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Copy the result back to Z ====
*
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ Z( JROW, INCOL+1 ), LDZ )
200 CONTINUE
END IF
END IF
END IF
210 CONTINUE
*
* ==== End of ZLAQR5 ====
*
END
*> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX*16 TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARF applies a complex elementary reflector H to a complex M-by-N
*> matrix C, from either the left or the right. H is represented in the
*> form
*>
*> H = I - tau * v * v**H
*>
*> where tau is a complex scalar and v is a complex vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*>
*> To apply H**H, supply conjg(tau) instead
*> tau.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
* Set up variables for scanning V. LASTV begins pointing to the end
* of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
* Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
* Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILAZLC(LASTV, N, C, LDC)
ELSE
* Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILAZLR(M, LASTV, C, LDC)
END IF
END IF
* Note that lastc.eq.0 renders the BLAS operations null; no special
* case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
*
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
$ C, LDC, V, INCV, ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
*
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of ZLARF
*
END
*> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFB applies a complex block reflector H or its transpose H**H to a
*> complex M-by-N matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**H from the Left
*> = 'R': apply H or H**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'C': apply H**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The triangular K-by-K matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2013
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C1**H
*
DO 10 J = 1, K
CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C( K+1, 1 ), LDC,
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
$ LDWORK, ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
DO 20 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
$ LDV, ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C2**H
*
DO 70 J = 1, K
CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
$ C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C1**H
*
DO 130 J = 1, K
CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
DO 140 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C( 1, K+1 ), LDC,
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C2**H
*
DO 190 J = 1, K
CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
$ LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', N, K, M-K, ONE, C,
$ LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, N, K, -ONE, V,
$ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
$ LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of ZLARFB
*
END
*> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFG generates a complex elementary reflector H of order n, such
*> that
*>
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, with beta real, and x is an
*> (n-1)-element complex vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
*> ( v )
*>
*> where tau is a complex scalar and v is a complex (n-1)-element
*> vector. Note that H is not hermitian.
*>
*> If the elements of x are all zero and alpha is real, then tau = 0
*> and H is taken to be the unit matrix.
*>
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHR = DBLE( ALPHA )
ALPHI = DIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHA = DCMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of ZLARFG
*
END
*> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFT forms the triangular factor T of a complex block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**H
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**H * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZLACGV, ZTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( PREVLASTV, I )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
*
CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
$ -TAU( I ), V( I+1, 1 ), LDV,
$ V( I+1, I ), 1, ONE, T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
*
CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
$ ONE, T( 1, I ), LDT )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
*
CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
$ 1, ONE, T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
*
CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
$ V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), LDT )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of ZLARFT
*
END
*> \brief \b ZLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER LDC, M, N
* COMPLEX*16 TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFX applies a complex elementary reflector H to a complex m by n
*> matrix C, from either the left or the right. H is represented in the
*> form
*>
*> H = I - tau * v * v**H
*>
*> where tau is a complex scalar and v is a complex vector.
*>
*> If tau = 0, then H is taken to be the unit matrix
*>
*> This version uses inline code if H has order < 11.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (M) if SIDE = 'L'
*> or (N) if SIDE = 'R'
*> The vector v in the representation of H.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> WORK is not referenced if H has order < 11.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER J
COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
$ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( TAU.EQ.ZERO )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C, where H has order m.
*
GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
$ 170, 190 )M
*
* Code for general M
*
CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
GO TO 410
10 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
DO 20 J = 1, N
C( 1, J ) = T1*C( 1, J )
20 CONTINUE
GO TO 410
30 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
DO 40 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
40 CONTINUE
GO TO 410
50 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
DO 60 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
60 CONTINUE
GO TO 410
70 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
DO 80 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
80 CONTINUE
GO TO 410
90 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
DO 100 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
100 CONTINUE
GO TO 410
110 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
V6 = DCONJG( V( 6 ) )
T6 = TAU*DCONJG( V6 )
DO 120 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
120 CONTINUE
GO TO 410
130 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
V6 = DCONJG( V( 6 ) )
T6 = TAU*DCONJG( V6 )
V7 = DCONJG( V( 7 ) )
T7 = TAU*DCONJG( V7 )
DO 140 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
140 CONTINUE
GO TO 410
150 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
V6 = DCONJG( V( 6 ) )
T6 = TAU*DCONJG( V6 )
V7 = DCONJG( V( 7 ) )
T7 = TAU*DCONJG( V7 )
V8 = DCONJG( V( 8 ) )
T8 = TAU*DCONJG( V8 )
DO 160 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
160 CONTINUE
GO TO 410
170 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
V6 = DCONJG( V( 6 ) )
T6 = TAU*DCONJG( V6 )
V7 = DCONJG( V( 7 ) )
T7 = TAU*DCONJG( V7 )
V8 = DCONJG( V( 8 ) )
T8 = TAU*DCONJG( V8 )
V9 = DCONJG( V( 9 ) )
T9 = TAU*DCONJG( V9 )
DO 180 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
180 CONTINUE
GO TO 410
190 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = DCONJG( V( 1 ) )
T1 = TAU*DCONJG( V1 )
V2 = DCONJG( V( 2 ) )
T2 = TAU*DCONJG( V2 )
V3 = DCONJG( V( 3 ) )
T3 = TAU*DCONJG( V3 )
V4 = DCONJG( V( 4 ) )
T4 = TAU*DCONJG( V4 )
V5 = DCONJG( V( 5 ) )
T5 = TAU*DCONJG( V5 )
V6 = DCONJG( V( 6 ) )
T6 = TAU*DCONJG( V6 )
V7 = DCONJG( V( 7 ) )
T7 = TAU*DCONJG( V7 )
V8 = DCONJG( V( 8 ) )
T8 = TAU*DCONJG( V8 )
V9 = DCONJG( V( 9 ) )
T9 = TAU*DCONJG( V9 )
V10 = DCONJG( V( 10 ) )
T10 = TAU*DCONJG( V10 )
DO 200 J = 1, N
SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
$ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
$ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
$ V10*C( 10, J )
C( 1, J ) = C( 1, J ) - SUM*T1
C( 2, J ) = C( 2, J ) - SUM*T2
C( 3, J ) = C( 3, J ) - SUM*T3
C( 4, J ) = C( 4, J ) - SUM*T4
C( 5, J ) = C( 5, J ) - SUM*T5
C( 6, J ) = C( 6, J ) - SUM*T6
C( 7, J ) = C( 7, J ) - SUM*T7
C( 8, J ) = C( 8, J ) - SUM*T8
C( 9, J ) = C( 9, J ) - SUM*T9
C( 10, J ) = C( 10, J ) - SUM*T10
200 CONTINUE
GO TO 410
ELSE
*
* Form C * H, where H has order n.
*
GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
$ 370, 390 )N
*
* Code for general N
*
CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
GO TO 410
210 CONTINUE
*
* Special code for 1 x 1 Householder
*
T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
DO 220 J = 1, M
C( J, 1 ) = T1*C( J, 1 )
220 CONTINUE
GO TO 410
230 CONTINUE
*
* Special code for 2 x 2 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
DO 240 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
240 CONTINUE
GO TO 410
250 CONTINUE
*
* Special code for 3 x 3 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
DO 260 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
260 CONTINUE
GO TO 410
270 CONTINUE
*
* Special code for 4 x 4 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
DO 280 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
280 CONTINUE
GO TO 410
290 CONTINUE
*
* Special code for 5 x 5 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
DO 300 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
300 CONTINUE
GO TO 410
310 CONTINUE
*
* Special code for 6 x 6 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
V6 = V( 6 )
T6 = TAU*DCONJG( V6 )
DO 320 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
320 CONTINUE
GO TO 410
330 CONTINUE
*
* Special code for 7 x 7 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
V6 = V( 6 )
T6 = TAU*DCONJG( V6 )
V7 = V( 7 )
T7 = TAU*DCONJG( V7 )
DO 340 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
340 CONTINUE
GO TO 410
350 CONTINUE
*
* Special code for 8 x 8 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
V6 = V( 6 )
T6 = TAU*DCONJG( V6 )
V7 = V( 7 )
T7 = TAU*DCONJG( V7 )
V8 = V( 8 )
T8 = TAU*DCONJG( V8 )
DO 360 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
360 CONTINUE
GO TO 410
370 CONTINUE
*
* Special code for 9 x 9 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
V6 = V( 6 )
T6 = TAU*DCONJG( V6 )
V7 = V( 7 )
T7 = TAU*DCONJG( V7 )
V8 = V( 8 )
T8 = TAU*DCONJG( V8 )
V9 = V( 9 )
T9 = TAU*DCONJG( V9 )
DO 380 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
380 CONTINUE
GO TO 410
390 CONTINUE
*
* Special code for 10 x 10 Householder
*
V1 = V( 1 )
T1 = TAU*DCONJG( V1 )
V2 = V( 2 )
T2 = TAU*DCONJG( V2 )
V3 = V( 3 )
T3 = TAU*DCONJG( V3 )
V4 = V( 4 )
T4 = TAU*DCONJG( V4 )
V5 = V( 5 )
T5 = TAU*DCONJG( V5 )
V6 = V( 6 )
T6 = TAU*DCONJG( V6 )
V7 = V( 7 )
T7 = TAU*DCONJG( V7 )
V8 = V( 8 )
T8 = TAU*DCONJG( V8 )
V9 = V( 9 )
T9 = TAU*DCONJG( V9 )
V10 = V( 10 )
T10 = TAU*DCONJG( V10 )
DO 400 J = 1, M
SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
$ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
$ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
$ V10*C( J, 10 )
C( J, 1 ) = C( J, 1 ) - SUM*T1
C( J, 2 ) = C( J, 2 ) - SUM*T2
C( J, 3 ) = C( J, 3 ) - SUM*T3
C( J, 4 ) = C( J, 4 ) - SUM*T4
C( J, 5 ) = C( J, 5 ) - SUM*T5
C( J, 6 ) = C( J, 6 ) - SUM*T6
C( J, 7 ) = C( J, 7 ) - SUM*T7
C( J, 8 ) = C( J, 8 ) - SUM*T8
C( J, 9 ) = C( J, 9 ) - SUM*T9
C( J, 10 ) = C( J, 10 ) - SUM*T10
400 CONTINUE
GO TO 410
END IF
410 CONTINUE
RETURN
*
* End of ZLARFX
*
END
*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARTG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CS
* COMPLEX*16 F, G, R, SN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARTG generates a plane rotation so that
*>
*> [ CS SN ] [ F ] [ R ]
*> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.
*> [ -SN CS ] [ G ] [ 0 ]
*>
*> This is a faster version of the BLAS1 routine ZROTG, except for
*> the following differences:
*> F and G are unchanged on return.
*> If G=0, then CS=1 and SN=0.
*> If F=0, then CS=0 and SN is chosen so that R is real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is COMPLEX*16
*> The first component of vector to be rotated.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is COMPLEX*16
*> The second component of vector to be rotated.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is DOUBLE PRECISION
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is COMPLEX*16
*> The sine of the rotation.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is COMPLEX*16
*> The nonzero component of the rotated vector.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
*>
*> This version has a few statements commented out for thread safety
*> (machine parameters are computed on each entry). 10 feb 03, SJH.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.5.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2013
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS
COMPLEX*16 F, G, R, SN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO, ONE, ZERO
PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
$ SAFMN2, SAFMX2, SCALE
COMPLEX*16 FF, FS, GS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
LOGICAL DISNAN
EXTERNAL DLAMCH, DLAPY2, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
$ MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1, ABSSQ
* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
COUNT = 0
IF( SCALE.GE.SAFMX2 ) THEN
10 CONTINUE
COUNT = COUNT + 1
FS = FS*SAFMN2
GS = GS*SAFMN2
SCALE = SCALE*SAFMN2
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F
RETURN
END IF
20 CONTINUE
COUNT = COUNT - 1
FS = FS*SAFMX2
GS = GS*SAFMX2
SCALE = SCALE*SAFMX2
IF( SCALE.LE.SAFMN2 )
$ GO TO 20
END IF
F2 = ABSSQ( FS )
G2 = ABSSQ( GS )
IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
*
* This is a rare case: F is very small.
*
IF( F.EQ.CZERO ) THEN
CS = ZERO
R = DLAPY2( DBLE( G ), DIMAG( G ) )
* Do complex/real division explicitly with two real divisions
D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
RETURN
END IF
F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
* G2 and G2S are accurate
* G2 is at least SAFMIN, and G2S is at least SAFMN2
G2S = SQRT( G2 )
* Error in CS from underflow in F2S is at most
* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
* and so CS .lt. sqrt(SAFMIN)
* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
CS = F2S / G2S
* Make sure abs(FF) = 1
* Do complex/real division explicitly with 2 real divisions
IF( ABS1( F ).GT.ONE ) THEN
D = DLAPY2( DBLE( F ), DIMAG( F ) )
FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
ELSE
DR = SAFMX2*DBLE( F )
DI = SAFMX2*DIMAG( F )
D = DLAPY2( DR, DI )
FF = DCMPLX( DR / D, DI / D )
END IF
SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
R = CS*F + SN*G
ELSE
*
* This is the most common case.
* Neither F2 nor F2/G2 are less than SAFMIN
* F2S cannot overflow, and it is accurate
*
F2S = SQRT( ONE+G2 / F2 )
* Do the F2S(real)*FS(complex) multiply with two real multiplies
R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
CS = ONE / F2S
D = F2 + G2
* Do complex/real division explicitly with two real divisions
SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
SN = SN*DCONJG( GS )
IF( COUNT.NE.0 ) THEN
IF( COUNT.GT.0 ) THEN
DO 30 I = 1, COUNT
R = R*SAFMX2
30 CONTINUE
ELSE
DO 40 I = 1, -COUNT
R = R*SAFMN2
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of ZLARTG
*
END
*> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TYPE
* INTEGER INFO, KL, KU, LDA, M, N
* DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASCL multiplies the M by N complex matrix A by the real scalar
*> CTO/CFROM. This is done without over/underflow as long as the final
*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
*> A may be full, upper triangular, lower triangular, upper Hessenberg,
*> or banded.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TYPE
*> \verbatim
*> TYPE is CHARACTER*1
*> TYPE indices the storage type of the input matrix.
*> = 'G': A is a full matrix.
*> = 'L': A is a lower triangular matrix.
*> = 'U': A is an upper triangular matrix.
*> = 'H': A is an upper Hessenberg matrix.
*> = 'B': A is a symmetric band matrix with lower bandwidth KL
*> and upper bandwidth KU and with the only the lower
*> half stored.
*> = 'Q': A is a symmetric band matrix with lower bandwidth KL
*> and upper bandwidth KU and with the only the upper
*> half stored.
*> = 'Z': A is a band matrix with lower bandwidth KL and upper
*> bandwidth KU. See ZGBTRF for storage details.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The lower bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The upper bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] CFROM
*> \verbatim
*> CFROM is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*> CTO is DOUBLE PRECISION
*>
*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
*> without over/underflow if the final result CTO*A(I,J)/CFROM
*> can be represented without over/underflow. CFROM must be
*> nonzero.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The matrix to be multiplied by CTO/CFROM. See TYPE for the
*> storage type.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> 0 - successful exit
*> <0 - if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( DISNAN(CTO) ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of ZLASCL
*
END
*> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASET initializes a 2-D array A to BETA on the diagonal and
*> ALPHA on the offdiagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be set.
*> = 'U': Upper triangular part is set. The lower triangle
*> is unchanged.
*> = 'L': Lower triangular part is set. The upper triangle
*> is unchanged.
*> Otherwise: All of the matrix A is set.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of A.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> All the offdiagonal array elements are set to ALPHA.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX*16
*> All the diagonal array elements are set to BETA.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
*> A(i,i) = BETA , 1 <= i <= min(m,n)
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the diagonal to BETA and the strictly upper triangular
* part of the array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( N, M )
A( I, I ) = BETA
30 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the diagonal to BETA and the strictly lower triangular
* part of the array to ALPHA.
*
DO 50 J = 1, MIN( M, N )
DO 40 I = J + 1, M
A( I, J ) = ALPHA
40 CONTINUE
50 CONTINUE
DO 60 I = 1, MIN( N, M )
A( I, I ) = BETA
60 CONTINUE
*
ELSE
*
* Set the array to BETA on the diagonal and ALPHA on the
* offdiagonal.
*
DO 80 J = 1, N
DO 70 I = 1, M
A( I, J ) = ALPHA
70 CONTINUE
80 CONTINUE
DO 90 I = 1, MIN( M, N )
A( I, I ) = BETA
90 CONTINUE
END IF
*
RETURN
*
* End of ZLASET
*
END
*> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, PIVOT, SIDE
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), S( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASR applies a sequence of real plane rotations to a complex matrix
*> A, from either the left or the right.
*>
*> When SIDE = 'L', the transformation takes the form
*>
*> A := P*A
*>
*> and when SIDE = 'R', the transformation takes the form
*>
*> A := A*P**T
*>
*> where P is an orthogonal matrix consisting of a sequence of z plane
*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
*> and P**T is the transpose of P.
*>
*> When DIRECT = 'F' (Forward sequence), then
*>
*> P = P(z-1) * ... * P(2) * P(1)
*>
*> and when DIRECT = 'B' (Backward sequence), then
*>
*> P = P(1) * P(2) * ... * P(z-1)
*>
*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*>
*> R(k) = ( c(k) s(k) )
*> = ( -s(k) c(k) ).
*>
*> When PIVOT = 'V' (Variable pivot), the rotation is performed
*> for the plane (k,k+1), i.e., P(k) has the form
*>
*> P(k) = ( 1 )
*> ( ... )
*> ( 1 )
*> ( c(k) s(k) )
*> ( -s(k) c(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*>
*> where R(k) appears as a rank-2 modification to the identity matrix in
*> rows and columns k and k+1.
*>
*> When PIVOT = 'T' (Top pivot), the rotation is performed for the
*> plane (1,k+1), so P(k) has the form
*>
*> P(k) = ( c(k) s(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*> ( -s(k) c(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*>
*> where R(k) appears in rows and columns 1 and k+1.
*>
*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
*> performed for the plane (k,z), giving P(k) the form
*>
*> P(k) = ( 1 )
*> ( ... )
*> ( 1 )
*> ( c(k) s(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*> ( -s(k) c(k) )
*>
*> where R(k) appears in rows and columns k and z. The rotations are
*> performed without ever forming P(k) explicitly.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> Specifies whether the plane rotation matrix P is applied to
*> A on the left or the right.
*> = 'L': Left, compute A := P*A
*> = 'R': Right, compute A:= A*P**T
*> \endverbatim
*>
*> \param[in] PIVOT
*> \verbatim
*> PIVOT is CHARACTER*1
*> Specifies the plane for which P(k) is a plane rotation
*> matrix.
*> = 'V': Variable pivot, the plane (k,k+1)
*> = 'T': Top pivot, the plane (1,k+1)
*> = 'B': Bottom pivot, the plane (k,z)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies whether P is a forward or backward sequence of
*> plane rotations.
*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. If m <= 1, an immediate
*> return is effected.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. If n <= 1, an
*> immediate return is effected.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The cosines c(k) of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The sines s(k) of the plane rotations. The 2-by-2 plane
*> rotation part of the matrix P(k), R(k), has the form
*> R(k) = ( c(k) s(k) )
*> ( -s(k) c(k) ).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The M-by-N matrix A. On exit, A is overwritten by P*A if
*> SIDE = 'R' or by A*P**T if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP
COMPLEX*16 TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P**T
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZLASR
*
END
*> \brief \b ZLASSQ updates a sum of squares represented in scaled form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASSQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASSQ returns the values scl and ssq such that
*>
*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*>
*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
*> assumed to be at least unity and the value of ssq will then satisfy
*>
*> 1.0 .le. ssq .le. ( sumsq + 2*n ).
*>
*> scale is assumed to be non-negative and scl returns the value
*>
*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
*> i
*>
*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
*>
*> The routine makes only one pass through the vector X.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements to be used from the vector X.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> The vector x as described above.
*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of the vector X.
*> INCX > 0.
*> \endverbatim
*>
*> \param[in,out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On entry, the value scale in the equation above.
*> On exit, SCALE is overwritten with the value scl .
*> \endverbatim
*>
*> \param[in,out] SUMSQ
*> \verbatim
*> SUMSQ is DOUBLE PRECISION
*> On entry, the value sumsq in the equation above.
*> On exit, SUMSQ is overwritten with the value ssq .
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION TEMP1
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
TEMP1 = ABS( DBLE( X( IX ) ) )
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
TEMP1 = ABS( DIMAG( X( IX ) ) )
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
*
RETURN
*
* End of ZLASSQ
*
END
*> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASWP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASWP performs a series of row interchanges on the matrix A.
*> One row interchange is initiated for each of rows K1 through K2 of A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the matrix of column dimension N to which the row
*> interchanges will be applied.
*> On exit, the permuted matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] K1
*> \verbatim
*> K1 is INTEGER
*> The first element of IPIV for which a row interchange will
*> be done.
*> \endverbatim
*>
*> \param[in] K2
*> \verbatim
*> K2 is INTEGER
*> The last element of IPIV for which a row interchange will
*> be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (K2*abs(INCX))
*> The vector of pivot indices. Only the elements in positions
*> K1 through K2 of IPIV are accessed.
*> IPIV(K) = L implies rows K and L are to be interchanged.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of IPIV. If IPIV
*> is negative, the pivots are applied in reverse order.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Modified by
*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
COMPLEX*16 TEMP
* ..
* .. Executable Statements ..
*
* Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
IF( INCX.GT.0 ) THEN
IX0 = K1
I1 = K1
I2 = K2
INC = 1
ELSE IF( INCX.LT.0 ) THEN
IX0 = 1 + ( 1-K2 )*INCX
I1 = K2
I2 = K1
INC = -1
ELSE
RETURN
END IF
*
N32 = ( N / 32 )*32
IF( N32.NE.0 ) THEN
DO 30 J = 1, N32, 32
IX = IX0
DO 20 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 10 K = J, J + 31
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
10 CONTINUE
END IF
IX = IX + INCX
20 CONTINUE
30 CONTINUE
END IF
IF( N32.NE.N ) THEN
N32 = N32 + 1
IX = IX0
DO 50 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 40 K = N32, N
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
40 CONTINUE
END IF
IX = IX + INCX
50 CONTINUE
END IF
*
RETURN
*
* End of ZLASWP
*
END
*> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION E( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
*> Hermitian tridiagonal form by a unitary similarity
*> transformation Q**H * A * Q, and returns the matrices V and W which are
*> needed to apply the transformation to the unreduced part of A.
*>
*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
*> matrix, of which the upper triangle is supplied;
*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
*> matrix, of which the lower triangle is supplied.
*>
*> This is an auxiliary routine called by ZHETRD.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of rows and columns to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit:
*> if UPLO = 'U', the last NB columns have been reduced to
*> tridiagonal form, with the diagonal elements overwriting
*> the diagonal elements of A; the elements above the diagonal
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors;
*> if UPLO = 'L', the first NB columns have been reduced to
*> tridiagonal form, with the diagonal elements overwriting
*> the diagonal elements of A; the elements below the diagonal
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
*> elements of the last NB columns of the reduced matrix;
*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
*> the first NB columns of the reduced matrix.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors, stored in
*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
*> See Further Details.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (LDW,NB)
*> The n-by-nb matrix W required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n) H(n-1) . . . H(n-nb+1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
*> and tau in TAU(i-1).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(nb).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
*> and tau in TAU(i).
*>
*> The elements of the vectors v together form the n-by-nb matrix V
*> which is needed, with W, to apply the transformation to the unreduced
*> part of the matrix, using a Hermitian rank-2k update of the form:
*> A := A - V*W**H - W*V**H.
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5 and nb = 2:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( a a a v4 v5 ) ( d )
*> ( a a v4 v5 ) ( 1 d )
*> ( a 1 v5 ) ( v1 1 a )
*> ( d 1 ) ( v1 v2 a a )
*> ( d ) ( v1 v2 a a a )
*>
*> where d denotes a diagonal element of the reduced matrix, a denotes
*> an element of the original matrix that is unchanged, and vi denotes
*> an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE, HALF
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IW
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
ALPHA = A( I-1, I )
CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = ALPHA
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* Reduce first NB columns of lower triangle
*
DO 20 I = 1, NB
*
* Update A(i:n,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of ZLATRD
*
END
*> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
* CNORM, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORMIN, TRANS, UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* DOUBLE PRECISION CNORM( * )
* COMPLEX*16 A( LDA, * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATRS solves one of the triangular systems
*>
*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
*>
*> with scaling to prevent overflow. Here A is an upper or lower
*> triangular matrix, A**T denotes the transpose of A, A**H denotes the
*> conjugate transpose of A, x and b are n-element vectors, and s is a
*> scaling factor, usually less than or equal to 1, chosen so that the
*> components of x will be less than the overflow threshold. If the
*> unscaled problem will not cause overflow, the Level 2 BLAS routine
*> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower triangular.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the operation applied to A.
*> = 'N': Solve A * x = s*b (No transpose)
*> = 'T': Solve A**T * x = s*b (Transpose)
*> = 'C': Solve A**H * x = s*b (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A is unit triangular.
*> = 'N': Non-unit triangular
*> = 'U': Unit triangular
*> \endverbatim
*>
*> \param[in] NORMIN
*> \verbatim
*> NORMIN is CHARACTER*1
*> Specifies whether CNORM has been set or not.
*> = 'Y': CNORM contains the column norms on entry
*> = 'N': CNORM is not set on entry. On exit, the norms will
*> be computed and stored in CNORM.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The triangular matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of the array A contains the upper
*> triangular matrix, and the strictly lower triangular part of
*> A is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of the array A contains the lower triangular
*> matrix, and the strictly upper triangular part of A is not
*> referenced. If DIAG = 'U', the diagonal elements of A are
*> also not referenced and are assumed to be 1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max (1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> On entry, the right hand side b of the triangular system.
*> On exit, X is overwritten by the solution vector x.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> The scaling factor s for the triangular system
*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
*> If SCALE = 0, the matrix A is singular or badly scaled, and
*> the vector x is an exact or approximate solution to A*x = 0.
*> \endverbatim
*>
*> \param[in,out] CNORM
*> \verbatim
*> CNORM is DOUBLE PRECISION array, dimension (N)
*>
*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
*> contains the norm of the off-diagonal part of the j-th column
*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal
*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
*> must be greater than or equal to the 1-norm.
*>
*> If NORMIN = 'N', CNORM is an output argument and CNORM(j)
*> returns the 1-norm of the offdiagonal part of the j-th column
*> of A.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A rough bound on x is computed; if that is less than overflow, ZTRSV
*> is called, otherwise, specific code is used which checks for possible
*> overflow or divide-by-zero at every operation.
*>
*> A columnwise scheme is used for solving A*x = b. The basic algorithm
*> if A is lower triangular is
*>
*> x[1:n] := b[1:n]
*> for j = 1, ..., n
*> x(j) := x(j) / A(j,j)
*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
*> end
*>
*> Define bounds on the components of x after j iterations of the loop:
*> M(j) = bound on x[1:j]
*> G(j) = bound on x[j+1:n]
*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*>
*> Then for iteration j+1 we have
*> M(j+1) <= G(j) / | A(j+1,j+1) |
*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*>
*> where CNORM(j+1) is greater than or equal to the infinity-norm of
*> column j+1 of A, not counting the diagonal. Hence
*>
*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
*> 1<=i<=j
*> and
*>
*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*> 1<=i< j
*>
*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the
*> reciprocal of the largest M(j), j=1,..,n, is larger than
*> max(underflow, 1/overflow).
*>
*> The bound on x(j) is also used to determine when a step in the
*> columnwise method can be performed without fear of overflow. If
*> the computed bound is greater than a large constant, x is scaled to
*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*>
*> Similarly, a row-wise scheme is used to solve A**T *x = b or
*> A**H *x = b. The basic algorithm for A upper triangular is
*>
*> for j = 1, ..., n
*> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
*> end
*>
*> We simultaneously compute two bounds
*> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
*> M(j) = bound on x(i), 1<=i<=j
*>
*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
*> Then the bound on x(j) is
*>
*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*>
*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
*> 1<=i<=j
*>
*> and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater
*> than max(underflow, 1/overflow).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION CNORM( * )
COMPLEX*16 A( LDA, * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
$ TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
$ XBND, XJ, XMAX
COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, IZAMAX
DOUBLE PRECISION DLAMCH, DZASUM
COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC,
$ ZDOTU, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1, CABS2
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) +
$ ABS( DIMAG( ZDUM ) / 2.D0 )
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLATRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N - 1
CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 )
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM/2.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM*HALF ) THEN
TSCAL = ONE
ELSE
TSCAL = HALF / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine ZTRSV can be used.
*
XMAX = ZERO
DO 30 J = 1, N
XMAX = MAX( XMAX, CABS2( X( J ) ) )
30 CONTINUE
XBND = XMAX
*
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 60
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = HALF / MAX( XBND, SMLNUM )
XBND = GROW
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 60
*
TJJS = A( J, J )
TJJ = CABS1( TJJS )
*
IF( TJJ.GE.SMLNUM ) THEN
*
* M(j) = G(j-1) / abs(A(j,j))
*
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
ELSE
*
* M(j) could overflow, set XBND to 0.
*
XBND = ZERO
END IF
*
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
40 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
DO 50 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 60
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
50 CONTINUE
END IF
60 CONTINUE
*
ELSE
*
* Compute the growth in A**T * x = b or A**H * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 90
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = HALF / MAX( XBND, SMLNUM )
XBND = GROW
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 90
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
TJJS = A( J, J )
TJJ = CABS1( TJJS )
*
IF( TJJ.GE.SMLNUM ) THEN
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
ELSE
*
* M(j) could overflow, set XBND to 0.
*
XBND = ZERO
END IF
70 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
DO 80 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 90
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
80 CONTINUE
END IF
90 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM*HALF ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = ( BIGNUM*HALF ) / XMAX
CALL ZDSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
ELSE
XMAX = XMAX*TWO
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 120 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 110
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
XJ = CABS1( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
XJ = CABS1( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 100 I = 1, N
X( I ) = ZERO
100 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
110 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL ZDSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
$ 1 )
I = IZAMAX( J-1, X, 1 )
XMAX = CABS1( X( I ) )
END IF
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
$ X( J+1 ), 1 )
I = J + IZAMAX( N-J, X( J+1 ), 1 )
XMAX = CABS1( X( I ) )
END IF
END IF
120 CONTINUE
*
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Solve A**T * x = b
*
DO 170 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = CABS1( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = ZLADIV( USCAL, TJJS )
END IF
IF( REC.LT.ONE ) THEN
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
CSUMJ = ZERO
IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call ZDOTU to perform the dot product.
*
IF( UPPER ) THEN
CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 130 I = 1, J - 1
CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
130 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 140 I = J + 1, N
CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
140 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
*
* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - CSUMJ
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 160
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0 and compute a solution to A**T *x = 0.
*
DO 150 I = 1, N
X( I ) = ZERO
150 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
160 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
END IF
XMAX = MAX( XMAX, CABS1( X( J ) ) )
170 CONTINUE
*
ELSE
*
* Solve A**H * x = b
*
DO 220 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = CABS1( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = DCONJG( A( J, J ) )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = ZLADIV( USCAL, TJJS )
END IF
IF( REC.LT.ONE ) THEN
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
CSUMJ = ZERO
IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call ZDOTC to perform the dot product.
*
IF( UPPER ) THEN
CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 180 I = 1, J - 1
CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
$ X( I )
180 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 190 I = J + 1, N
CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
$ X( I )
190 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
*
* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - CSUMJ
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = DCONJG( A( J, J ) )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 210
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0 and compute a solution to A**H *x = 0.
*
DO 200 I = 1, N
X( I ) = ZERO
200 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
210 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
END IF
XMAX = MAX( XMAX, CABS1( X( J ) ) )
220 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of ZLATRS
*
END
*> \brief \b ZPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOTF2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTF2 computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A.
*>
*> The factorization has the form
*> A = U**H * U , if UPLO = 'U', or
*> A = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n by n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n by n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> > 0: if INFO = k, the leading minor of order k is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16POcomputational
*
* =====================================================================
SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**H *U.
*
DO 10 J = 1, N
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1,
$ A( 1, J ), 1 )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of row J.
*
IF( J.LT.N ) THEN
CALL ZLACGV( J-1, A( 1, J ), 1 )
CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ),
$ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA )
CALL ZLACGV( J-1, A( 1, J ), 1 )
CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L*L**H.
*
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA,
$ A( J, 1 ), LDA )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
A( J, J ) = AJJ
*
* Compute elements J+1:N of column J.
*
IF( J.LT.N ) THEN
CALL ZLACGV( J-1, A( J, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ),
$ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 )
CALL ZLACGV( J-1, A( J, 1 ), LDA )
CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of ZPOTF2
*
END
*> \brief \b ZPOTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A.
*>
*> The factorization has the form
*> A = U**H * U, if UPLO = 'U', or
*> A = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the block version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,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: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16POcomputational
*
* =====================================================================
SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
COMPLEX*16 CONE
PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
CALL ZPOTF2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code.
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**H *U.
*
DO 10 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1,
$ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block row.
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB,
$ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA,
$ A( 1, J+JB ), LDA, CONE, A( J, J+JB ),
$ LDA )
CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
$ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
$ LDA, A( J, J+JB ), LDA )
END IF
10 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization A = L*L**H.
*
DO 20 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
$ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block column.
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ),
$ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ),
$ LDA )
CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
$ LDA, A( J+JB, J ), LDA )
END IF
20 CONTINUE
END IF
END IF
GO TO 40
*
30 CONTINUE
INFO = INFO + J - 1
*
40 CONTINUE
RETURN
*
* End of ZPOTRF
*
END
*> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZROT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* .. Scalar Arguments ..
* INTEGER INCX, INCY, N
* DOUBLE PRECISION C
* COMPLEX*16 S
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * ), CY( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZROT applies a plane rotation, where the cos (C) is real and the
*> sin (S) is complex, and the vectors CX and CY are complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vectors CX and CY.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> On input, the vector X.
*> On output, CX is overwritten with C*X + S*Y.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX*16 array, dimension (N)
*> On input, the vector Y.
*> On output, CY is overwritten with -CONJG(S)*X + C*Y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16
*> C and S define a rotation
*> [ C S ]
*> [ -conjg(S) C ]
*> where C*C + S*CONJG(S) = 1.0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INCX, INCY, N
DOUBLE PRECISION C
COMPLEX*16 S
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * ), CY( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY
COMPLEX*16 STEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* Code for unequal increments or equal increments not equal to 1
*
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
STEMP = C*CX( IX ) + S*CY( IY )
CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
CX( IX ) = STEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
20 CONTINUE
DO 30 I = 1, N
STEMP = C*CX( I ) + S*CY( I )
CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
CX( I ) = STEMP
30 CONTINUE
RETURN
END
*> \brief \b ZSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), WORK( * )
* COMPLEX*16 Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
*> symmetric tridiagonal matrix using the implicit QL or QR method.
*> The eigenvectors of a full or band complex Hermitian matrix can also
*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
*> matrix to tridiagonal form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': Compute eigenvalues only.
*> = 'V': Compute eigenvalues and eigenvectors of the original
*> Hermitian matrix. On entry, Z must contain the
*> unitary matrix used to reduce the original matrix
*> to tridiagonal form.
*> = 'I': Compute eigenvalues and eigenvectors of the
*> tridiagonal matrix. Z is initialized to the identity
*> matrix.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
*> matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> On entry, if COMPZ = 'V', then Z contains the unitary
*> matrix used in the reduction to tridiagonal form.
*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
*> orthonormal eigenvectors of the original Hermitian matrix,
*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors
*> of the symmetric tridiagonal matrix.
*> If COMPZ = 'N', then Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> eigenvectors are desired, then LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
*> If COMPZ = 'N', then WORK is not referenced.
*> \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 algorithm has failed to find all the eigenvalues in
*> a total of 30*N iterations; if INFO = i, then i
*> elements of E have not converged to zero; on exit, D
*> and E contain the elements of a symmetric tridiagonal
*> matrix which is unitarily similar to the original
*> matrix.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
$ ZLASET, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.EQ.NMAXIT ) THEN
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
RETURN
END IF
GO TO 10
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
RETURN
*
* End of ZSTEQR
*
END
*> \brief \b ZTRCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRCON + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
* RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORM, UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRCON estimates the reciprocal of the condition number of a
*> triangular matrix A, in either the 1-norm or the infinity-norm.
*>
*> The norm of A is computed and an estimate is obtained for
*> norm(inv(A)), then the reciprocal of the condition number is
*> computed as
*> RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies whether the 1-norm condition number or the
*> infinity-norm condition number is required:
*> = '1' or 'O': 1-norm;
*> = 'I': Infinity-norm.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': A is upper triangular;
*> = 'L': A is lower triangular.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> = 'N': A is non-unit triangular;
*> = 'U': A is unit triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The triangular matrix A. If UPLO = 'U', the leading N-by-N
*> upper triangular part of the array A contains the upper
*> triangular matrix, and the strictly lower triangular part of
*> A is not referenced. If UPLO = 'L', the leading N-by-N lower
*> triangular part of the array A contains the lower triangular
*> matrix, and the strictly upper triangular part of A is not
*> referenced. If DIAG = 'U', the diagonal elements of A are
*> also not referenced and are assumed to be 1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(norm(A) * norm(inv(A))).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
$ RWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, ONENRM, UPPER
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH, ZLANTR
EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTR
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATRS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
NOUNIT = LSAME( DIAG, 'N' )
*
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
END IF
*
RCOND = ZERO
SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
*
* Compute the norm of the triangular matrix A.
*
ANORM = ZLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK )
*
* Continue only if ANORM > 0.
*
IF( ANORM.GT.ZERO ) THEN
*
* Estimate the norm of the inverse of A.
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(A).
*
CALL ZLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
$ LDA, WORK, SCALE, RWORK, INFO )
ELSE
*
* Multiply by inv(A**H).
*
CALL ZLATRS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
$ N, A, LDA, WORK, SCALE, RWORK, INFO )
END IF
NORMIN = 'Y'
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
IF( SCALE.NE.ONE ) THEN
IX = IZAMAX( N, WORK, 1 )
XNORM = CABS1( WORK( IX ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL ZDRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / ANORM ) / AINVNM
END IF
*
20 CONTINUE
RETURN
*
* End of ZTRCON
*
END
*> \brief \b ZTREVC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREVC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
* LDVR, MM, M, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, SIDE
* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTREVC computes some or all of the right and/or left eigenvectors of
*> a complex upper triangular matrix T.
*> Matrices of this type are produced by the Schur factorization of
*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
*>
*> The right eigenvector x and the left eigenvector y of T corresponding
*> to an eigenvalue w are defined by:
*>
*> T*x = w*x, (y**H)*T = w*(y**H)
*>
*> where y**H denotes the conjugate transpose of the vector y.
*> The eigenvalues are not input to this routine, but are read directly
*> from the diagonal of T.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
*> input matrix. If Q is the unitary factor that reduces a matrix A to
*> Schur form T, then Q*X and Q*Y are the matrices of right and left
*> eigenvectors of A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'R': compute right eigenvectors only;
*> = 'L': compute left eigenvectors only;
*> = 'B': compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*> HOWMNY is CHARACTER*1
*> = 'A': compute all right and/or left eigenvectors;
*> = 'B': compute all right and/or left eigenvectors,
*> backtransformed using the matrices supplied in
*> VR and/or VL;
*> = 'S': compute selected right and/or left eigenvectors,
*> as indicated by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be
*> computed.
*> The eigenvector corresponding to the j-th eigenvalue is
*> computed if SELECT(j) = .TRUE..
*> Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> The upper triangular matrix T. T is modified, but restored
*> on exit.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,MM)
*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*> contain an N-by-N matrix Q (usually the unitary matrix Q of
*> Schur vectors returned by ZHSEQR).
*> On exit, if SIDE = 'L' or 'B', VL contains:
*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
*> if HOWMNY = 'B', the matrix Q*Y;
*> if HOWMNY = 'S', the left eigenvectors of T specified by
*> SELECT, stored consecutively in the columns
*> of VL, in the same order as their
*> eigenvalues.
*> Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the array VL. LDVL >= 1, and if
*> SIDE = 'L' or 'B', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,MM)
*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*> contain an N-by-N matrix Q (usually the unitary matrix Q of
*> Schur vectors returned by ZHSEQR).
*> On exit, if SIDE = 'R' or 'B', VR contains:
*> if HOWMNY = 'A', the matrix X of right eigenvectors of T;
*> if HOWMNY = 'B', the matrix Q*X;
*> if HOWMNY = 'S', the right eigenvectors of T specified by
*> SELECT, stored consecutively in the columns
*> of VR, in the same order as their
*> eigenvalues.
*> Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR. LDVR >= 1, and if
*> SIDE = 'R' or 'B'; LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*> MM is INTEGER
*> The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The number of columns in the arrays VL and/or VR actually
*> used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
*> is set to N. Each selected eigenvector occupies one
*> column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The algorithm used in this program is basically backward (forward)
*> substitution, with scaling to make the the code robust against
*> possible overflow.
*>
*> Each eigenvector is normalized so that the element of largest
*> magnitude has magnitude 1; here the magnitude of a complex number
*> (x,y) is taken to be |x| + |y|.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, RWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CMZERO, CMONE
PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ),
$ CMONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
INTEGER I, II, IS, J, K, KI
DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
COMPLEX*16 CDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH, DZASUM
EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
* Set M to the number of columns required to store the selected
* eigenvectors.
*
IF( SOMEV ) THEN
M = 0
DO 10 J = 1, N
IF( SELECT( J ) )
$ M = M + 1
10 CONTINUE
ELSE
M = N
END IF
*
INFO = 0
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE IF( MM.LT.M ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREVC', -INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Set the constants to control overflow.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
*
* Store the diagonal elements of T in working array WORK.
*
DO 20 I = 1, N
WORK( I+N ) = T( I, I )
20 CONTINUE
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
RWORK( 1 ) = ZERO
DO 30 J = 2, N
RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 )
30 CONTINUE
*
IF( RIGHTV ) THEN
*
* Compute right eigenvectors.
*
IS = M
DO 80 KI = N, 1, -1
*
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 80
END IF
SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
WORK( 1 ) = CMONE
*
* Form right-hand side.
*
DO 40 K = 1, KI - 1
WORK( K ) = -T( K, KI )
40 CONTINUE
*
* Solve the triangular system:
* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
*
DO 50 K = 1, KI - 1
T( K, K ) = T( K, K ) - T( KI, KI )
IF( CABS1( T( K, K ) ).LT.SMIN )
$ T( K, K ) = SMIN
50 CONTINUE
*
IF( KI.GT.1 ) THEN
CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
$ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK,
$ INFO )
WORK( KI ) = SCALE
END IF
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 )
*
II = IZAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / CABS1( VR( II, IS ) )
CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 60 K = KI + 1, N
VR( K, IS ) = CMZERO
60 CONTINUE
ELSE
IF( KI.GT.1 )
$ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ),
$ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 )
*
II = IZAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / CABS1( VR( II, KI ) )
CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 )
END IF
*
* Set back the original diagonal elements of T.
*
DO 70 K = 1, KI - 1
T( K, K ) = WORK( K+N )
70 CONTINUE
*
IS = IS - 1
80 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* Compute left eigenvectors.
*
IS = 1
DO 130 KI = 1, N
*
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
END IF
SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
WORK( N ) = CMONE
*
* Form right-hand side.
*
DO 90 K = KI + 1, N
WORK( K ) = -DCONJG( T( KI, K ) )
90 CONTINUE
*
* Solve the triangular system:
* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK.
*
DO 100 K = KI + 1, N
T( K, K ) = T( K, K ) - T( KI, KI )
IF( CABS1( T( K, K ) ).LT.SMIN )
$ T( K, K ) = SMIN
100 CONTINUE
*
IF( KI.LT.N ) THEN
CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ 'Y', N-KI, T( KI+1, KI+1 ), LDT,
$ WORK( KI+1 ), SCALE, RWORK, INFO )
WORK( KI ) = SCALE
END IF
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 )
*
II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / CABS1( VL( II, IS ) )
CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
*
DO 110 K = 1, KI - 1
VL( K, IS ) = CMZERO
110 CONTINUE
ELSE
IF( KI.LT.N )
$ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1 ), 1, DCMPLX( SCALE ),
$ VL( 1, KI ), 1 )
*
II = IZAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / CABS1( VL( II, KI ) )
CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 )
END IF
*
* Set back the original diagonal elements of T.
*
DO 120 K = KI + 1, N
T( K, K ) = WORK( K+N )
120 CONTINUE
*
IS = IS + 1
130 CONTINUE
END IF
*
RETURN
*
* End of ZTREVC
*
END
*> \brief \b ZTREXC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREXC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ
* INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
* COMPLEX*16 Q( LDQ, * ), T( LDT, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTREXC reorders the Schur factorization of a complex matrix
*> A = Q*T*Q**H, so that the diagonal element of T with row index IFST
*> is moved to row ILST.
*>
*> The Schur form T is reordered by a unitary similarity transformation
*> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
*> postmultplying it with Z.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'V': update the matrix Q of Schur vectors;
*> = 'N': do not update Q.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> On entry, the upper triangular matrix T.
*> On exit, the reordered upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
*> On exit, if COMPQ = 'V', Q has been postmultiplied by the
*> unitary transformation matrix Z which reorders T.
*> If COMPQ = 'N', Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[in] IFST
*> \verbatim
*> IFST is INTEGER
*> \endverbatim
*>
*> \param[in] ILST
*> \verbatim
*> ILST is INTEGER
*>
*> Specify the reordering of the diagonal elements of T:
*> The element with row index IFST is moved to row ILST by a
*> sequence of transpositions between adjacent elements.
*> 1 <= IFST <= N; 1 <= ILST <= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER COMPQ
INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
COMPLEX*16 Q( LDQ, * ), T( LDT, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL WANTQ
INTEGER K, M1, M2, M3
DOUBLE PRECISION CS
COMPLEX*16 SN, T11, T22, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARTG, ZROT
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
INFO = 0
WANTQ = LSAME( COMPQ, 'V' )
IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -7
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.1 .OR. IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Move the IFST-th diagonal element forward down the diagonal.
*
M1 = 0
M2 = -1
M3 = 1
ELSE
*
* Move the IFST-th diagonal element backward up the diagonal.
*
M1 = -1
M2 = 0
M3 = -1
END IF
*
DO 10 K = IFST + M1, ILST + M2, M3
*
* Interchange the k-th and (k+1)-th diagonal elements.
*
T11 = T( K, K )
T22 = T( K+1, K+1 )
*
* Determine the transformation to perform the interchange.
*
CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP )
*
* Apply transformation to the matrix T.
*
IF( K+2.LE.N )
$ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS,
$ SN )
CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS,
$ DCONJG( SN ) )
*
T( K, K ) = T22
T( K+1, K+1 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS,
$ DCONJG( SN ) )
END IF
*
10 CONTINUE
*
RETURN
*
* End of ZTREXC
*
END
*> \brief \b ZTRTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRTRS solves a triangular system of the form
*>
*> A * X = B, A**T * X = B, or A**H * X = B,
*>
*> where A is a triangular matrix of order N, and B is an N-by-NRHS
*> matrix. A check is made to verify that A is nonsingular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': A is upper triangular;
*> = 'L': A is lower triangular.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the form of the system of equations:
*> = 'N': A * X = B (No transpose)
*> = 'T': A**T * X = B (Transpose)
*> = 'C': A**H * X = B (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> = 'N': A is non-unit triangular;
*> = 'U': A is unit triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The triangular matrix A. If UPLO = 'U', the leading N-by-N
*> upper triangular part of the array A contains the upper
*> triangular matrix, and the strictly lower triangular part of
*> A is not referenced. If UPLO = 'L', the leading N-by-N lower
*> triangular part of the array A contains the lower triangular
*> matrix, and the strictly upper triangular part of A is not
*> referenced. If DIAG = 'U', the diagonal elements of A are
*> also not referenced and are assumed to be 1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, if INFO = 0, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,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: if INFO = i, the i-th diagonal element of A is zero,
*> indicating that the matrix is singular and the solutions
*> X have not been computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
$ INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
$ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
END IF
INFO = 0
*
* Solve A * x = b, A**T * x = b, or A**H * x = b.
*
CALL ZTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
$ LDB )
*
RETURN
*
* End of ZTRTRS
*
END
*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNG2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
*> which is defined as the last n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQLF in the last k columns of its array
*> argument A.
*> On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2L
*
END
*> \brief \b ZUNG2R
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNG2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
*> which is defined as the first n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQRF in the first k columns of its array
*> argument A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2R
*
END
*> \brief \b ZUNGBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER VECT
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGBR generates one of the complex unitary matrices Q or P**H
*> determined by ZGEBRD when reducing a complex matrix A to bidiagonal
*> form: A = Q * B * P**H. Q and P**H are defined as products of
*> elementary reflectors H(i) or G(i) respectively.
*>
*> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
*> is of order M:
*> if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
*> columns of Q, where m >= n >= k;
*> if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
*> M-by-M matrix.
*>
*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
*> is of order N:
*> if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
*> rows of P**H, where n >= m >= k;
*> if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
*> an N-by-N matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] VECT
*> \verbatim
*> VECT is CHARACTER*1
*> Specifies whether the matrix Q or the matrix P**H is
*> required, as defined in the transformation applied by ZGEBRD:
*> = 'Q': generate Q;
*> = 'P': generate P**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q or P**H to be returned.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q or P**H to be returned.
*> N >= 0.
*> If VECT = 'Q', M >= N >= min(M,K);
*> if VECT = 'P', N >= M >= min(N,K).
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> If VECT = 'Q', the number of columns in the original M-by-K
*> matrix reduced by ZGEBRD.
*> If VECT = 'P', the number of rows in the original K-by-N
*> matrix reduced by ZGEBRD.
*> K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZGEBRD.
*> On exit, the M-by-N matrix Q or P**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension
*> (min(M,K)) if VECT = 'Q'
*> (min(N,K)) if VECT = 'P'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i) or G(i), which determines Q or P**H, as
*> returned by ZGEBRD in its array argument TAUQ or TAUP.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,min(M,N)).
*> For optimum performance LWORK >= min(M,N)*NB, where NB
*> is the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16GBcomputational
*
* =====================================================================
SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTQ
INTEGER I, IINFO, J, LWKOPT, MN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGLQ, ZUNGQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTQ = LSAME( VECT, 'Q' )
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
$ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
$ MIN( N, K ) ) ) ) THEN
INFO = -3
ELSE IF( K.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = 1
IF( WANTQ ) THEN
IF( M.GE.K ) THEN
CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( M.GT.1 ) THEN
CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ -1, IINFO )
END IF
END IF
ELSE
IF( K.LT.N ) THEN
CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( N.GT.1 ) THEN
CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ -1, IINFO )
END IF
END IF
END IF
LWKOPT = WORK( 1 )
LWKOPT = MAX (LWKOPT, MN)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
WORK( 1 ) = LWKOPT
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( WANTQ ) THEN
*
* Form Q, determined by a call to ZGEBRD to reduce an m-by-k
* matrix
*
IF( M.GE.K ) THEN
*
* If m >= k, assume m >= n >= k
*
CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If m < k, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q
* to those of the unit matrix
*
DO 20 J = M, 2, -1
A( 1, J ) = ZERO
DO 10 I = J + 1, M
A( I, J ) = A( I, J-1 )
10 CONTINUE
20 CONTINUE
A( 1, 1 ) = ONE
DO 30 I = 2, M
A( I, 1 ) = ZERO
30 CONTINUE
IF( M.GT.1 ) THEN
*
* Form Q(2:m,2:m)
*
CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
ELSE
*
* Form P**H, determined by a call to ZGEBRD to reduce a k-by-n
* matrix
*
IF( K.LT.N ) THEN
*
* If k < n, assume k <= m <= n
*
CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If k >= n, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* row downward, and set the first row and column of P**H to
* those of the unit matrix
*
A( 1, 1 ) = ONE
DO 40 I = 2, N
A( I, 1 ) = ZERO
40 CONTINUE
DO 60 J = 2, N
DO 50 I = J - 1, 2, -1
A( I, J ) = A( I-1, J )
50 CONTINUE
A( 1, J ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Form P**H(2:n,2:n)
*
CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGBR
*
END
*> \brief \b ZUNGHR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGHR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGHR generates a complex unitary matrix Q which is defined as the
*> product of IHI-ILO elementary reflectors of order N, as returned by
*> ZGEHRD:
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> ILO and IHI must have the same values as in the previous call
*> of ZGEHRD. Q is equal to the unit matrix except in the
*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZGEHRD.
*> On exit, the N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEHRD.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 >= IHI-ILO.
*> For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LWKOPT, NB, NH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGQR
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 )
LWKOPT = MAX( 1, NH )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first ilo and the last n-ihi
* rows and columns to those of the unit matrix
*
DO 40 J = IHI, ILO + 1, -1
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
DO 20 I = J + 1, IHI
A( I, J ) = A( I, J-1 )
20 CONTINUE
DO 30 I = IHI + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
DO 60 J = 1, ILO
DO 50 I = 1, N
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = ONE
60 CONTINUE
DO 80 J = IHI + 1, N
DO 70 I = 1, N
A( I, J ) = ZERO
70 CONTINUE
A( J, J ) = ONE
80 CONTINUE
*
IF( NH.GT.0 ) THEN
*
* Generate Q(ilo+1:ihi,ilo+1:ihi)
*
CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
$ WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGHR
*
END
*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGL2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
*> which is defined as the first m rows of a product of k elementary
*> reflectors of order n
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th row must contain the vector which defines
*> the elementary reflector H(i), for i = 1,2,...,k, as returned
*> by ZGELQF in the first k rows of its array argument A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGL2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows k+1:m to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = K + 1, M
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.K .AND. J.LE.M )
$ A( J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = K, 1, -1
*
* Apply H(i)**H to A(i:m,i:n) from the right
*
IF( I.LT.N ) THEN
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
IF( I.LT.M ) THEN
A( I, I ) = ONE
CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
END IF
CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
END IF
A( I, I ) = ONE - DCONJG( TAU( I ) )
*
* Set A(i,1:i-1) to zero
*
DO 30 L = 1, I - 1
A( I, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNGL2
*
END
*> \brief \b ZUNGLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
*> which is defined as the first M rows of a product of K elementary
*> reflectors of order N
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th row must contain the vector which defines
*> the elementary reflector H(i), for i = 1,2,...,k, as returned
*> by ZGELQF in the first k rows of its array argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit;
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, M )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(kk+1:m,1:kk) to zero.
*
DO 20 J = 1, KK
DO 10 I = KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.M )
$ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**H to A(i+ib:m,i:n) from the right
*
CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H**H to columns i:n of current block
*
CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set columns 1:i-1 of current block to zero
*
DO 40 J = 1, I - 1
DO 30 L = I, I + IB - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGLQ
*
END
*> \brief \b ZUNGQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
*> which is defined as the last N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQLF in the last k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
$ NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk columns are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(m-kk+1:m,1:n-kk) to zero.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL ZLARFB( 'Left', 'No transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows 1:m-k+i+ib-1 of current block
*
CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* Set rows m-k+i+ib:m of current block to zero
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGQL
*
END
*> \brief \b ZUNGQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
*> which is defined as the first N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQRF in the first k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, N )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(1:kk,kk+1:n) to zero.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.N )
$ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.N ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i:m,i+ib:n) from the left
*
CALL ZLARFB( 'Left', 'No transpose', 'Forward',
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows i:m of current block
*
CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set rows 1:i-1 of current block to zero
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGQR
*
END
*> \brief \b ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,
*> which is defined as the last m rows of a product of k elementary
*> reflectors of order n
*>
*> Q = H(1)**H H(2)**H . . . H(k)**H
*>
*> as returned by ZGERQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (m-k+i)-th row must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGERQF in the last k rows of its array argument
*> A.
*> On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGERQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGR2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows 1:m-k to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = 1, M - K
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.N-M .AND. J.LE.N-K )
$ A( M-N+J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = 1, K
II = M - K + I
*
* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right
*
CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
A( II, N-M+II ) = ONE
CALL ZLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
$ DCONJG( TAU( I ) ), A, LDA, WORK )
CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - DCONJG( TAU( I ) )
*
* Set A(m-k+i,n-k+i+1:n) to zero
*
DO 30 L = N - M + II + 1, N
A( II, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNGR2
*
END
*> \brief \b ZUNGRQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGRQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,
*> which is defined as the last M rows of a product of K elementary
*> reflectors of order N
*>
*> Q = H(1)**H H(2)**H . . . H(k)**H
*>
*> as returned by ZGERQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (m-k+i)-th row must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGERQF in the last k rows of its array argument
*> A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGERQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGR2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'ZUNGRQ', ' ', M, N, K, -1 )
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGRQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGRQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGRQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk rows are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(1:m-kk,n-kk+1:n) to zero.
*
DO 20 J = N - KK + 1, N
DO 10 I = 1, M - KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL ZUNGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
II = M - K + I
IF( II.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL ZLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
$ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
CALL ZLARFB( 'Right', 'Conjugate transpose', 'Backward',
$ 'Rowwise', II-1, N-K+I+IB-1, IB, A( II, 1 ),
$ LDA, WORK, LDWORK, A, LDA, WORK( IB+1 ),
$ LDWORK )
END IF
*
* Apply H**H to columns 1:n-k+i+ib-1 of current block
*
CALL ZUNGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
$ WORK, IINFO )
*
* Set columns n-k+i+ib:n of current block to zero
*
DO 40 L = N - K + I + IB, N
DO 30 J = II, II + IB - 1
A( J, L ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGRQ
*
END
*> \brief \b ZUNGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGTR generates a complex unitary matrix Q which is defined as the
*> product of n-1 elementary reflectors of order N, as returned by
*> ZHETRD:
*>
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A contains elementary reflectors
*> from ZHETRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from ZHETRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZHETRD.
*> On exit, the N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= N.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZHETRD.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 >= N-1.
*> For optimum performance LWORK >= (N-1)*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, J, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGQL, ZUNGQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 )
ELSE
NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 )
END IF
LWKOPT = MAX( 1, N-1 )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHETRD with UPLO = 'U'
*
* Shift the vectors which define the elementary reflectors one
* column to the left, and set the last row and column of Q to
* those of the unit matrix
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHETRD with UPLO = 'L'.
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q to
* those of the unit matrix
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGTR
*
END
*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNM2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNM2R overwrites the general complex m-by-n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**H if SIDE = 'R' and TRANS = 'C',
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left
*> = 'R': apply Q or Q**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQRF in the first k columns of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m-by-n matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNM2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = A( I, I )
A( I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
$ WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of ZUNM2R
*
END
*> \brief \b ZUNMBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
* LDC, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, VECT
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
*> with
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
*> with
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': P * C C * P
*> TRANS = 'C': P**H * C C * P**H
*>
*> Here Q and P**H are the unitary matrices determined by ZGEBRD when
*> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
*> and P**H are defined as products of elementary reflectors H(i) and
*> G(i) respectively.
*>
*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
*> order of the unitary matrix Q or P**H that is applied.
*>
*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
*> if nq >= k, Q = H(1) H(2) . . . H(k);
*> if nq < k, Q = H(1) H(2) . . . H(nq-1).
*>
*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
*> if k < nq, P = G(1) G(2) . . . G(k);
*> if k >= nq, P = G(1) G(2) . . . G(nq-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] VECT
*> \verbatim
*> VECT is CHARACTER*1
*> = 'Q': apply Q or Q**H;
*> = 'P': apply P or P**H.
*> \endverbatim
*>
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q, Q**H, P or P**H from the Left;
*> = 'R': apply Q, Q**H, P or P**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q or P;
*> = 'C': Conjugate transpose, apply Q**H or P**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> If VECT = 'Q', the number of columns in the original
*> matrix reduced by ZGEBRD.
*> If VECT = 'P', the number of rows in the original
*> matrix reduced by ZGEBRD.
*> K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,min(nq,K)) if VECT = 'Q'
*> (LDA,nq) if VECT = 'P'
*> The vectors which define the elementary reflectors H(i) and
*> G(i), whose products determine the matrices Q and P, as
*> returned by ZGEBRD.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If VECT = 'Q', LDA >= max(1,nq);
*> if VECT = 'P', LDA >= max(1,min(nq,K)).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(nq,K))
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i) or G(i) which determines Q or P, as returned
*> by ZGEBRD in the array argument TAUQ or TAUP.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
*> or P*C or P**H*C or C*P or C*P**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M);
*> if N = 0 or M = 0, LWORK >= 1.
*> For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
*> and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
*> optimal blocksize. (NB = 0 if M = 0 or N = 0.)
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, VECT
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMLQ, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
APPLYQ = LSAME( VECT, 'Q' )
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q or P and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
NW = 0
END IF
IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( K.LT.0 ) THEN
INFO = -6
ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
$ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
$ THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( NW.GT.0 ) THEN
IF( APPLYQ ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW*NB )
ELSE
LWKOPT = 1
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( APPLYQ ) THEN
*
* Apply Q
*
IF( NQ.GE.K ) THEN
*
* Q was determined by a call to ZGEBRD with nq >= k
*
CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* Q was determined by a call to ZGEBRD with nq < k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
ELSE
*
* Apply P
*
IF( NOTRAN ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
IF( NQ.GT.K ) THEN
*
* P was determined by a call to ZGEBRD with nq > k
*
CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* P was determined by a call to ZGEBRD with nq <= k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
$ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMBR
*
END
*> \brief \b ZUNMHR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMHR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
* LDC, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMHR overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix of order nq, with nq = m if
*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
*> IHI-ILO elementary reflectors, as returned by ZGEHRD:
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> ILO and IHI must have the same values as in the previous call
*> of ZGEHRD. Q is equal to the unit matrix except in the
*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
*> ILO = 1 and IHI = 0, if M = 0;
*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
*> ILO = 1 and IHI = 0, if N = 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L'
*> (LDA,N) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by ZGEHRD.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEHRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LEFT = LSAME( SIDE, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
$ THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
INFO = -5
ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 )
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = NH
NI = N
I1 = ILO + 1
I2 = 1
ELSE
MI = M
NI = NH
I1 = 1
I2 = ILO + 1
END IF
*
CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
$ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMHR
*
END
*> \brief \b ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNML2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNML2 overwrites the general complex m-by-n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**H if SIDE = 'R' and TRANS = 'C',
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left
*> = 'R': apply Q or Q**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L',
*> (LDA,N) if SIDE = 'R'
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGELQF in the first k rows of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,K).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m-by-n matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNML2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = DCONJG( TAU( I ) )
ELSE
TAUI = TAU( I )
END IF
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
AII = A( I, I )
A( I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
$ LDC, WORK )
A( I, I ) = AII
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
10 CONTINUE
RETURN
*
* End of ZUNML2
*
END
*> \brief \b ZUNMLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMLQ overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Conjugate transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L',
*> (LDA,N) if SIDE = 'R'
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGELQF in the first k rows of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,K).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE 'L', and
*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
COMPLEX*16 T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size. NB may be at most NBMAX, where NBMAX
* is used to define the local array T.
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
ELSE
IWS = NW
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
IF( NOTRAN ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
$ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK,
$ LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMLQ
*
END
*> \brief \b ZUNMQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMQR overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Conjugate transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQRF in the first k columns of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT
PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. Local Arrays ..
COMPLEX*16 T( LDT, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size. NB may be at most NBMAX, where NBMAX
* is used to define the local array T.
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IWS = NW*NB
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
ELSE
IWS = NW
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), T, LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
$ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQR
*
END
*> \brief \b ZGESDD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESDD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESDD( 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( * )
* DOUBLE PRECISION RWORK( * ), S( * )
* COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESDD 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*16 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 DOUBLE PRECISION 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*16 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*16 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*16 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).
*> if JOBZ = 'O',
*> LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
*> if JOBZ = 'S' or 'A',
*> LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
*> For good performance, LWORK should generally be larger.
*>
*> 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.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> If JOBZ = 'N', LRWORK >= 5*min(M,N).
*> Otherwise,
*> LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)
*> \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 DBDSDC did not converge.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEsing
*
*> \par Contributors:
* ==================
*>
*> Ming Gu and Huan Ren, Computer Science Division, University of
*> California at Berkeley, USA
*>
* =====================================================================
SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, RWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER JOBZ
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION RWORK( * ), S( * )
COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER LQUERV
PARAMETER ( LQUERV = -1 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL 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
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM,
$ ZGEQRF, ZLACP2, ZLACPY, ZLACRM, ZLARCM, ZLASCL,
$ ZLASET, ZUNGBR, ZUNGLQ, ZUNGQR, ZUNMBR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
MNTHR1 = INT( MINMN*17.0D0 / 9.0D0 )
MNTHR2 = INT( MINMN*5.0D0 / 3.0D0 )
WNTQA = LSAME( JOBZ, 'A' )
WNTQS = LSAME( JOBZ, 'S' )
WNTQAS = WNTQA .OR. WNTQS
WNTQO = LSAME( JOBZ, 'O' )
WNTQN = LSAME( JOBZ, 'N' )
MINWRK = 1
MAXWRK = 1
*
IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
$ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
INFO = -8
ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
$ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
$ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* 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.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN
IF( M.GE.N ) THEN
*
* There is no complex work space needed for bidiagonal SVD
* The real work space needed for bidiagonal SVD is BDSPAC
* for computing singular values and singular vectors; BDSPAN
* for computing singular values only.
* BDSPAC = 5*N*N + 7*N
* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8))
*
IF( M.GE.MNTHR1 ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M much larger than N, JOBZ='N')
*
MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, 2*N+2*N*
$ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
MINWRK = 3*N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M much larger than N, JOBZ='O')
*
WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+2*N*
$ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
MAXWRK = M*N + N*N + WRKBL
MINWRK = 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than N, JOBZ='S')
*
WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
$ N, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+2*N*
$ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
MAXWRK = N*N + WRKBL
MINWRK = N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than N, JOBZ='A')
*
WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
$ M, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+2*N*
$ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
WRKBL = MAX( WRKBL, 2*N+N*
$ ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
MAXWRK = N*N + WRKBL
MINWRK = N*N + 2*N + M
END IF
ELSE IF( M.GE.MNTHR2 ) THEN
*
* Path 5 (M much larger than N, but not as much as MNTHR1)
*
MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
$ -1, -1 )
MINWRK = 2*N + M
IF( WNTQO ) THEN
MAXWRK = MAX( MAXWRK, 2*N+N*
$ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N+N*
$ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
MAXWRK = MAXWRK + M*N
MINWRK = MINWRK + N*N
ELSE IF( WNTQS ) THEN
MAXWRK = MAX( MAXWRK, 2*N+N*
$ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N+N*
$ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
ELSE IF( WNTQA ) THEN
MAXWRK = MAX( MAXWRK, 2*N+N*
$ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N+M*
$ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
END IF
ELSE
*
* Path 6 (M at least N, but not much larger)
*
MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
$ -1, -1 )
MINWRK = 2*N + M
IF( WNTQO ) 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 ) )
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
* for computing singular values and singular vectors; BDSPAN
* for computing singular values only.
* BDSPAC = 5*M*M + 7*M
* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8))
*
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 )
END IF
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = MAXWRK
IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV )
$ INFO = -13
END IF
*
* Quick returns
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESDD', -INFO )
RETURN
END IF
IF( LWORK.EQ.LQUERV )
$ RETURN
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
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)
*
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)
*
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 BDSPAN)
*
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)
*
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)
*
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)
*
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 )
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 )
CALL ZUNMBR( '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 2*N*N, prefer N*N+M*N)
* (RWorkspace: 0)
*
DO 10 I = 1, M, LDWRKR
CHUNK = MIN( M-I+1, LDWRKR )
CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
$ LDA, WORK( IU ), LDWRKU, CZERO,
$ WORK( IR ), LDWRKR )
CALL ZLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3 (M much larger than 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+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
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)
*
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 N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
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 bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(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 U
* Overwrite U by left singular vectors of R
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
CALL ZUNMBR( '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+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
CALL ZUNMBR( '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)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ),
$ LDWRKR, CZERO, U, LDU )
*
ELSE IF( WNTQA ) THEN
*
* Path 4 (M much larger than 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 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce R in A, zeroing out below it
*
CALL ZLASET( '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 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( 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 BDSPAC)
*
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 left singular vectors of R
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
$ LDWRKU )
CALL ZUNMBR( '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 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
CALL ZUNMBR( '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)
* (RWorkspace: 0)
*
CALL ZGEMM( '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 ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
END IF
*
ELSE IF( M.GE.MNTHR2 ) THEN
*
* MNTHR2 <= M < MNTHR1
*
* Path 5 (M much larger than N, but not as much as MNTHR1)
* Reduce to bidiagonal form without QR decomposition, use
* ZUNGBR 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+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Compute singular values only
* (Cworkspace: 0)
* (Rworkspace: need BDSPAN)
*
CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IRU = NRWORK
IRVT = IRU + N*N
NRWORK = IRVT + N*N
*
* Copy A to VT, generate P**H
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Generate Q in A
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.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
END IF
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 BDSPAC)
*
CALL DBDSDC( '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 0)
* (Rworkspace: need 3*N*N)
*
CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT,
$ WORK( IU ), LDWRKU, RWORK( NRWORK ) )
CALL ZLACPY( '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 N*N, prefer M*N)
* (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
*
NRWORK = IRVT
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA, RWORK( IRU ),
$ N, WORK( IU ), LDWRKU, RWORK( NRWORK ) )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
20 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Copy A to VT, generate P**H
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy A to U, generate Q
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
CALL ZUNGBR( '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 BDSPAC)
*
IRU = NRWORK
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 )
*
* Multiply real matrix RWORK(IRVT) by P**H in VT,
* storing the result in A, copying to VT
* (Cworkspace: need 0)
* (Rworkspace: need 3*N*N)
*
CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( '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*N+2*M*N)
*
NRWORK = IRVT
CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
ELSE
*
* Copy A to VT, generate P**H
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Copy A to U, generate Q
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
CALL ZUNGBR( '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 BDSPAC)
*
IRU = NRWORK
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 )
*
* Multiply real matrix RWORK(IRVT) by P**H in VT,
* storing the result in A, copying to VT
* (Cworkspace: need 0)
* (Rworkspace: need 3*N*N)
*
CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( '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: 0)
* (Rworkspace: need 3*N*N)
*
NRWORK = IRVT
CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
END IF
*
ELSE
*
* M .LT. MNTHR2
*
* Path 6 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
* Use ZUNMBR to compute singular vectors
*
IE = 1
NRWORK = IE + N
ITAUQ = 1
ITAUP = ITAUQ + N
NWORK = ITAUP + N
*
* Bidiagonalize A
* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Compute singular values only
* (Cworkspace: 0)
* (Rworkspace: need BDSPAN)
*
CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IU = NWORK
IRU = NRWORK
IRVT = IRU + N*N
NRWORK = IRVT + N*N
IF( LWORK.GE.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
END IF
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 BDSPAC)
*
CALL DBDSDC( '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, prefer N+N*NB)
* (Rworkspace: need 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*N ) THEN
*
* Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
* Overwrite WORK(IU) by left singular vectors of A, copying
* to A
* (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB)
* (Rworkspace: need 0)
*
CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IU ),
$ LDWRKU )
CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
$ LDWRKU )
CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), WORK( IU ), LDWRKU,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
CALL ZLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
ELSE
*
* Generate Q in A
* (Cworkspace: need 2*N, prefer N+N*NB)
* (Rworkspace: need 0)
*
CALL ZUNGBR( '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 N*N, prefer M*N)
* (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
*
NRWORK = IRVT
DO 30 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA,
$ RWORK( IRU ), N, WORK( IU ), LDWRKU,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
30 CONTINUE
END IF
*
ELSE IF( WNTQS ) THEN
*
* 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 BDSPAC)
*
IRU = NRWORK
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 U
* Overwrite U by left singular vectors of A
* (CWorkspace: need 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLASET( 'F', M, N, CZERO, CZERO, U, LDU )
CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
CALL ZUNMBR( '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 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE
*
* 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 BDSPAC)
*
IRU = NRWORK
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 )
*
* Set the right corner of U to identity matrix
*
CALL ZLASET( 'F', M, M, CZERO, CZERO, U, LDU )
IF( M.GT.N ) THEN
CALL ZLASET( 'F', M-N, M-N, CZERO, CONE,
$ U( N+1, N+1 ), LDU )
END IF
*
* Copy real matrix RWORK(IRU) to complex matrix U
* Overwrite U by left singular vectors of A
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
CALL ZUNMBR( '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 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR1 ) THEN
*
IF( WNTQN ) THEN
*
* Path 1t (N much larger than M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Zero out above L
*
CALL ZLASET( '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 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( 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: 0)
* (RWorkspace: need BDSPAN)
*
CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2t (N much larger than 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.GE.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
END IF
ITAU = IL + LDWRKL*CHUNK
NWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing about above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( 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+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( 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 BDSPAC)
*
IRU = IE + M
IRVT = IRU + M*M
NRWORK = IRVT + M*M
CALL DBDSDC( '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 N*N+3*N, prefer M*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( '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 N*N+3*N, prefer M*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
$ LDWKVT )
CALL ZUNMBR( '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 2*M*M, prefer M*M+M*N))
* (RWorkspace: 0)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IVT ), M,
$ A( 1, I ), LDA, CZERO, WORK( IL ),
$ LDWRKL )
CALL ZLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
$ A( 1, I ), LDA )
40 CONTINUE
*
ELSE IF( WNTQS ) THEN
*
* Path 3t (N much larger than 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 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
* Copy L to WORK(IL), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IL+LDWRKL ), LDWRKL )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( 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+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( 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 BDSPAC)
*
IRU = IE + M
IRVT = IRU + M*M
NRWORK = IRVT + M*M
CALL DBDSDC( '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+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( '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+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
CALL ZUNMBR( '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)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL,
$ A, LDA, CZERO, VT, LDVT )
*
ELSE IF( WNTQA ) THEN
*
* Path 9t (N much larger than 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 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Produce L in A, zeroing out above it
*
CALL ZLASET( '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+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( 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 BDSPAC)
*
IRU = IE + M
IRVT = IRU + M*M
NRWORK = IRVT + M*M
CALL DBDSDC( '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 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( '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+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
$ LDWKVT )
CALL ZUNMBR( '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)
* (RWorkspace: 0)
*
CALL ZGEMM( '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 ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
END IF
*
ELSE IF( N.GE.MNTHR2 ) THEN
*
* MNTHR2 <= N < MNTHR1
*
* Path 5t (N much larger than M, but not as much as MNTHR1)
* Reduce to bidiagonal form without QR decomposition, use
* ZUNGBR 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+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
IF( WNTQN ) THEN
*
* Compute singular values only
* (Cworkspace: 0)
* (Rworkspace: need BDSPAN)
*
CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
IVT = NWORK
*
* Copy A to U, generate Q
* (Cworkspace: need 2*M, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
* Generate P**H in A
* (Cworkspace: need 2*M, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
*
LDWKVT = M
IF( LWORK.GE.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
END IF
*
* 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 BDSPAC)
*
CALL DBDSDC( '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 0)
* (Rworkspace: need 2*M*M)
*
CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ),
$ LDWKVT, RWORK( NRWORK ) )
CALL ZLACPY( '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 M*M, prefer M*N)
* (Rworkspace: need 2*M*M, prefer 2*M*N)
*
NRWORK = IRU
DO 50 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ), LDA,
$ WORK( IVT ), LDWKVT, RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
$ A( 1, I ), LDA )
50 CONTINUE
ELSE IF( WNTQS ) THEN
*
* Copy A to U, generate Q
* (Cworkspace: need 2*M, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZUNGBR( '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, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
CALL ZUNGBR( '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 BDSPAC)
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
CALL DBDSDC( '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 3*M*M)
*
CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( '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*M+2*M*N)
*
NRWORK = IRU
CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
ELSE
*
* Copy A to U, generate Q
* (Cworkspace: need 2*M, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZUNGBR( '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, prefer M+M*NB)
* (Rworkspace: 0)
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
CALL ZUNGBR( '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 BDSPAC)
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
CALL DBDSDC( '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 3*M*M)
*
CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( '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*M+2*M*N)
*
CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
END IF
*
ELSE
*
* N .LT. MNTHR2
*
* Path 6t (N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
* Use ZUNMBR to compute singular vectors
*
IE = 1
NRWORK = IE + M
ITAUQ = 1
ITAUP = ITAUQ + M
NWORK = ITAUP + M
*
* Bidiagonalize A
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Compute singular values only
* (Cworkspace: 0)
* (Rworkspace: need BDSPAN)
*
CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
LDWKVT = M
IVT = NWORK
IF( LWORK.GE.M*N+3*M ) THEN
*
* WORK( IVT ) is M by N
*
CALL ZLASET( '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
END IF
*
* 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 BDSPAC)
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
CALL DBDSDC( '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, prefer M+M*NB)
* (Rworkspace: need 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
*
IF( LWORK.GE.M*N+3*M ) THEN
*
* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
* Overwrite WORK(IVT) by right singular vectors of A,
* copying to A
* (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB)
* (Rworkspace: need 0)
*
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
$ LDWKVT )
CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), WORK( IVT ), LDWKVT,
$ WORK( NWORK ), LWORK-NWORK+1, IERR )
CALL ZLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
ELSE
*
* Generate P**H in A
* (Cworkspace: need 2*M, prefer M+M*NB)
* (Rworkspace: need 0)
*
CALL ZUNGBR( '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 M*M, prefer M*N)
* (Rworkspace: need 3*M*M, prefer M*M+2*M*N)
*
NRWORK = IRU
DO 60 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ),
$ LDA, WORK( IVT ), LDWKVT,
$ RWORK( NRWORK ) )
CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
$ A( 1, I ), LDA )
60 CONTINUE
END IF
ELSE IF( WNTQS ) THEN
*
* 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 BDSPAC)
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
CALL DBDSDC( '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 3*M, prefer 2*M+M*NB)
* (RWorkspace: M*M)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( '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 3*M, prefer 2*M+M*NB)
* (RWorkspace: M*M)
*
CALL ZLASET( 'F', M, N, CZERO, CZERO, VT, LDVT )
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
ELSE
*
* 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 BDSPAC)
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
*
CALL DBDSDC( '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 3*M, prefer 2*M+M*NB)
* (RWorkspace: M*M)
*
CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
CALL ZUNMBR( '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 ZLASET( '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+N, prefer 2*M+N*NB)
* (RWorkspace: M*M)
*
CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
CALL ZUNMBR( 'P', 'R', 'C', N, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
$ LWORK-NWORK+1, IERR )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
IF( ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of ZGESDD
*
END
*> \brief \b ZLACP2 copies all or part of a real two-dimensional array to a complex array.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACP2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* COMPLEX*16 B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACP2 copies all or part of a real two-dimensional matrix A to a
*> complex matrix B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be copied to B.
*> = 'U': Upper triangular part
*> = 'L': Lower triangular part
*> Otherwise: All of the matrix A
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A. If UPLO = 'U', only the upper trapezium
*> is accessed; if UPLO = 'L', only the lower trapezium is
*> accessed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> On exit, B = A in the locations specified by UPLO.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
COMPLEX*16 B( LDB, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
*
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
RETURN
*
* End of ZLACP2
*
END
*> \brief \b ZLACRM multiplies a complex matrix by a square real matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACRM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION B( LDB, * ), RWORK( * )
* COMPLEX*16 A( LDA, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACRM performs a very simple matrix-matrix multiplication:
*> C := A * B,
*> where A is M by N and complex; B is N by N and real;
*> C is M by N and complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A and of the matrix C.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns and rows of the matrix B and
*> the number of columns of the matrix C.
*> N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> A contains the M by N matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >=max(1,M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, N)
*> B contains the N by N matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >=max(1,N).
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> C contains the M by N matrix C.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >=max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*M*N)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), RWORK( * )
COMPLEX*16 A( LDA, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Executable Statements ..
*
* Quick return if possible.
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
*
DO 20 J = 1, N
DO 10 I = 1, M
RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) )
10 CONTINUE
20 CONTINUE
*
L = M*N + 1
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 40 J = 1, N
DO 30 I = 1, M
C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
30 CONTINUE
40 CONTINUE
*
DO 60 J = 1, N
DO 50 I = 1, M
RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) )
50 CONTINUE
60 CONTINUE
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 80 J = 1, N
DO 70 I = 1, M
C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
$ RWORK( L+( J-1 )*M+I-1 ) )
70 CONTINUE
80 CONTINUE
*
RETURN
*
* End of ZLACRM
*
END
*> \brief \b ZLARCM copies all or part of a real two-dimensional array to a complex array.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARCM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), RWORK( * )
* COMPLEX*16 B( LDB, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARCM performs a very simple matrix-matrix multiplication:
*> C := A * B,
*> where A is M by M and real; B is M by N and complex;
*> C is M by N and complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A and of the matrix C.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns and rows of the matrix B and
*> the number of columns of the matrix C.
*> N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, M)
*> A contains the M by M matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >=max(1,M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, N)
*> B contains the M by N matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >=max(1,M).
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> C contains the M by N matrix C.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >=max(1,M).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*M*N)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- LAPACK auxiliary routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), RWORK( * )
COMPLEX*16 B( LDB, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Executable Statements ..
*
* Quick return if possible.
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
*
DO 20 J = 1, N
DO 10 I = 1, M
RWORK( ( J-1 )*M+I ) = DBLE( B( I, J ) )
10 CONTINUE
20 CONTINUE
*
L = M*N + 1
CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
$ RWORK( L ), M )
DO 40 J = 1, N
DO 30 I = 1, M
C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
30 CONTINUE
40 CONTINUE
*
DO 60 J = 1, N
DO 50 I = 1, M
RWORK( ( J-1 )*M+I ) = DIMAG( B( I, J ) )
50 CONTINUE
60 CONTINUE
CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
$ RWORK( L ), M )
DO 80 J = 1, N
DO 70 I = 1, M
C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
$ RWORK( L+( J-1 )*M+I-1 ) )
70 CONTINUE
80 CONTINUE
*
RETURN
*
* End of ZLARCM
*
END
*> \brief ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELSD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
* WORK, LWORK, RWORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION RWORK( * ), S( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELSD computes the minimum-norm solution to a real linear least
*> squares problem:
*> minimize 2-norm(| b - A*x |)
*> using the singular value decomposition (SVD) of A. A is an M-by-N
*> matrix which may be rank-deficient.
*>
*> Several right hand side vectors b and solution vectors x can be
*> handled in a single call; they are stored as the columns of the
*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*> matrix X.
*>
*> The problem is solved in three steps:
*> (1) Reduce the coefficient matrix A to bidiagonal form with
*> Householder tranformations, reducing the original problem
*> into a "bidiagonal least squares problem" (BLS)
*> (2) Solve the BLS using a divide and conquer approach.
*> (3) Apply back all the Householder tranformations to solve
*> the original least squares problem.
*>
*> The effective rank of A is determined by treating as zero those
*> singular values which are less than RCOND times the largest singular
*> value.
*>
*> 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] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrices B and X. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, A has been destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the M-by-NRHS right hand side matrix B.
*> On exit, B is overwritten by the N-by-NRHS solution matrix X.
*> If m >= n and RANK = n, the residual sum-of-squares for
*> the solution in the i-th column is given by the sum of
*> squares of the modulus of elements n+1:m in that column.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M,N).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (min(M,N))
*> The singular values of A in decreasing order.
*> The condition number of A in the 2-norm = S(1)/S(min(m,n)).
*> \endverbatim
*>
*> \param[in] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> RCOND is used to determine the effective rank of A.
*> Singular values S(i) <= RCOND*S(1) are treated as zero.
*> If RCOND < 0, machine precision is used instead.
*> \endverbatim
*>
*> \param[out] RANK
*> \verbatim
*> RANK is INTEGER
*> The effective rank of A, i.e., the number of singular values
*> which are greater than RCOND*S(1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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 must be at least 1.
*> The exact minimum amount of workspace needed depends on M,
*> N and NRHS. As long as LWORK is at least
*> 2*N + N*NRHS
*> if M is greater than or equal to N or
*> 2*M + M*NRHS
*> if M is less than N, the code will execute correctly.
*> For good performance, LWORK should generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the array WORK and the
*> minimum sizes of the arrays RWORK and IWORK, and returns
*> these values as the first entries of the WORK, RWORK and
*> IWORK arrays, and no error message related to LWORK is issued
*> by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> LRWORK >=
*> 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
*> MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
*> if M is greater than or equal to N or
*> 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
*> MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
*> if M is less than N, the code will execute correctly.
*> SMLSIZ is returned by ILAENV and is equal to the maximum
*> size of the subproblems at the bottom of the computation
*> tree (usually about 25), and
*> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
*> On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*> LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
*> where MINMN = MIN( M,N ).
*> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
*> \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 algorithm for computing the SVD failed to converge;
*> if INFO = i, i off-diagonal elements of an intermediate
*> bidiagonal form did not converge to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16GEsolve
*
*> \par Contributors:
* ==================
*>
*> Ming Gu and Ren-Cang Li, Computer Science Division, University of
*> California at Berkeley, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*
* =====================================================================
SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
$ WORK, LWORK, RWORK, IWORK, INFO )
*
* -- LAPACK driver routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION RWORK( * ), S( * )
COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
$ LDWORK, LIWORK, LRWORK, MAXMN, MAXWRK, MINMN,
$ MINWRK, MM, MNTHR, NLVL, NRWORK, NWORK, SMLSIZ
DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, DLASCL, DLASET, XERBLA, ZGEBRD, ZGELQF,
$ ZGEQRF, ZLACPY, ZLALSD, ZLASCL, ZLASET, ZUNMBR,
$ ZUNMLQ, ZUNMQR
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, LOG, MAX, MIN, DBLE
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MINMN = MIN( M, N )
MAXMN = MAX( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
INFO = -7
END IF
*
* Compute workspace.
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
LIWORK = 1
LRWORK = 1
IF( MINMN.GT.0 ) THEN
SMLSIZ = ILAENV( 9, 'ZGELSD', ' ', 0, 0, 0, 0 )
MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 )
NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ + 1 ) ) /
$ LOG( TWO ) ) + 1, 0 )
LIWORK = 3*MINMN*NLVL + 11*MINMN
MM = M
IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than
* columns.
*
MM = N
MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'ZGEQRF', ' ', M, N,
$ -1, -1 ) )
MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'ZUNMQR', 'LC', M,
$ NRHS, N, -1 ) )
END IF
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
LRWORK = 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
$ MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
$ 'ZGEBRD', ' ', MM, N, -1, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR',
$ 'QLC', MM, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
$ 'ZUNMBR', 'PLN', N, NRHS, N, -1 ) )
MAXWRK = MAX( MAXWRK, 2*N + N*NRHS )
MINWRK = MAX( 2*N + MM, 2*N + N*NRHS )
END IF
IF( N.GT.M ) THEN
LRWORK = 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
$ MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
IF( N.GE.MNTHR ) THEN
*
* Path 2a - underdetermined, with many more columns
* than rows.
*
MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
$ -1 )
MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
$ 'ZGEBRD', ' ', M, M, -1, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
$ 'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
$ 'ZUNMLQ', 'LC', N, NRHS, M, -1 ) )
IF( NRHS.GT.1 ) THEN
MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
ELSE
MAXWRK = MAX( MAXWRK, M*M + 2*M )
END IF
MAXWRK = MAX( MAXWRK, M*M + 4*M + M*NRHS )
! XXX: Ensure the Path 2a case below is triggered. The workspace
! calculation should use queries for all routines eventually.
MAXWRK = MAX( MAXWRK,
$ 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
ELSE
*
* Path 2 - underdetermined.
*
MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M,
$ N, -1, -1 )
MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR',
$ 'QLC', M, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNMBR',
$ 'PLN', N, NRHS, M, -1 ) )
MAXWRK = MAX( MAXWRK, 2*M + M*NRHS )
END IF
MINWRK = MAX( 2*M + N, 2*M + M*NRHS )
END IF
END IF
MINWRK = MIN( MINWRK, MAXWRK )
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWORK
RWORK( 1 ) = LRWORK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELSD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RANK = 0
RETURN
END IF
*
* Get machine parameters.
*
EPS = DLAMCH( 'P' )
SFMIN = DLAMCH( 'S' )
SMLNUM = SFMIN / EPS
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
*
* Scale A if max entry outside range [SMLNUM,BIGNUM].
*
ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
IASCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM
*
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
IASCL = 1
ELSE IF( ANRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
IASCL = 2
ELSE IF( ANRM.EQ.ZERO ) THEN
*
* Matrix all zero. Return zero solution.
*
CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
RANK = 0
GO TO 10
END IF
*
* Scale B if max entry outside range [SMLNUM,BIGNUM].
*
BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
IBSCL = 0
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
* Scale matrix norm up to SMLNUM.
*
CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
IBSCL = 1
ELSE IF( BNRM.GT.BIGNUM ) THEN
*
* Scale matrix norm down to BIGNUM.
*
CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
IBSCL = 2
END IF
*
* If M < N make sure B(M+1:N,:) = 0
*
IF( M.LT.N )
$ CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
*
* Overdetermined case.
*
IF( M.GE.N ) THEN
*
* Path 1 - overdetermined or exactly determined.
*
MM = M
IF( M.GE.MNTHR ) THEN
*
* Path 1a - overdetermined, with many more rows than columns
*
MM = N
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R.
* (RWorkspace: need N)
* (CWorkspace: need N, prefer N*NB)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose(Q).
* (RWorkspace: need N)
* (CWorkspace: need NRHS, prefer NRHS*NB)
*
CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Zero out below R.
*
IF( N.GT.1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
$ LDA )
END IF
END IF
*
ITAUQ = 1
ITAUP = ITAUQ + N
NWORK = ITAUP + N
IE = 1
NRWORK = IE + N
*
* Bidiagonalize R in A.
* (RWorkspace: need N)
* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
*
CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of R.
* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
*
CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL ZLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
$ IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of R.
*
CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
$ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
*
* Path 2a - underdetermined, with many more columns than rows
* and sufficient workspace for an efficient algorithm.
*
LDWORK = M
IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
$ M*LDA+M+M*NRHS ) )LDWORK = LDA
ITAU = 1
NWORK = M + 1
*
* Compute A=L*Q.
* (CWorkspace: need 2*M, prefer M+M*NB)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
IL = NWORK
*
* Copy L to WORK(IL), zeroing out above its diagonal.
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
$ LDWORK )
ITAUQ = IL + LDWORK*M
ITAUP = ITAUQ + M
NWORK = ITAUP + M
IE = 1
NRWORK = IE + M
*
* Bidiagonalize L in WORK(IL).
* (RWorkspace: need M)
* (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB)
*
CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors of L.
* (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*
CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL ZLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
$ IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of L.
*
CALL ZUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
$ WORK( ITAUP ), B, LDB, WORK( NWORK ),
$ LWORK-NWORK+1, INFO )
*
* Zero out below first M rows of B.
*
CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
NWORK = ITAU + M
*
* Multiply transpose(Q) by B.
* (CWorkspace: need NRHS, prefer NRHS*NB)
*
CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
$ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
ELSE
*
* Path 2 - remaining underdetermined cases.
*
ITAUQ = 1
ITAUP = ITAUQ + M
NWORK = ITAUP + M
IE = 1
NRWORK = IE + M
*
* Bidiagonalize A.
* (RWorkspace: need M)
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ INFO )
*
* Multiply B by transpose of left bidiagonalizing vectors.
* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
*
CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
* Solve the bidiagonal least squares problem.
*
CALL ZLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
$ RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
$ IWORK, INFO )
IF( INFO.NE.0 ) THEN
GO TO 10
END IF
*
* Multiply B by right bidiagonalizing vectors of A.
*
CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
$ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
*
END IF
*
* Undo scaling.
*
IF( IASCL.EQ.1 ) THEN
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
END IF
*
10 CONTINUE
WORK( 1 ) = MAXWRK
IWORK( 1 ) = LIWORK
RWORK( 1 ) = LRWORK
RETURN
*
* End of ZGELSD
*
END
*> \brief \b ZLALSD uses the singular value decomposition of A to solve the least squares problem.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLALSD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
* RANK, WORK, RWORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLALSD uses the singular value decomposition of A to solve the least
*> squares problem of finding X to minimize the Euclidean norm of each
*> column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
*> are N-by-NRHS. The solution X overwrites B.
*>
*> The singular values of A smaller than RCOND times the largest
*> singular value are treated as zero in solving the least squares
*> problem; in this case a minimum norm solution is returned.
*> The actual singular values are returned in D in ascending order.
*>
*> This code 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 XMP, Cray YMP, 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] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': D and E define an upper bidiagonal matrix.
*> = 'L': D and E define a lower bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] SMLSIZ
*> \verbatim
*> SMLSIZ is INTEGER
*> The maximum size of the subproblems at the bottom of the
*> computation tree.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the bidiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B. NRHS must be at least 1.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry D contains the main diagonal of the bidiagonal
*> matrix. On exit, if INFO = 0, D contains its singular values.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> Contains the super-diagonal entries of the bidiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On input, B contains the right hand sides of the least
*> squares problem. On output, B contains the solution X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of B in the calling subprogram.
*> LDB must be at least max(1,N).
*> \endverbatim
*>
*> \param[in] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The singular values of A less than or equal to RCOND times
*> the largest singular value are treated as zero in solving
*> the least squares problem. If RCOND is negative,
*> machine precision is used instead.
*> For example, if diag(S)*X=B were the least squares problem,
*> where diag(S) is a diagonal matrix of singular values, the
*> solution would be X(i) = B(i) / S(i) if S(i) is greater than
*> RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
*> RCOND*max(S).
*> \endverbatim
*>
*> \param[out] RANK
*> \verbatim
*> RANK is INTEGER
*> The number of singular values of A greater than RCOND times
*> the largest singular value.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension at least
*> (N * NRHS).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension at least
*> (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
*> MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),
*> where
*> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension at least
*> (3*N*NLVL + 11*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 algorithm failed to compute a singular value while
*> working on the submatrix lying in rows and columns
*> INFO/(N+1) through MOD(INFO,N+1).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Ming Gu and Ren-Cang Li, Computer Science Division, University of
*> California at Berkeley, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*
* =====================================================================
SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
$ RANK, WORK, RWORK, IWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
$ GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB,
$ IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG,
$ JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB,
$ PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1,
$ U, VT, Z
DOUBLE PRECISION CS, EPS, ORGNRM, RCND, R, SN, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL IDAMAX, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLARTG, DLASCL, DLASDA, DLASDQ, DLASET,
$ DLASRT, XERBLA, ZCOPY, ZDROT, ZLACPY, ZLALSA,
$ ZLASCL, ZLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, LOG, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLALSD', -INFO )
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
* Set up the tolerance.
*
IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
RCND = EPS
ELSE
RCND = RCOND
END IF
*
RANK = 0
*
* Quick return if possible.
*
IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
IF( D( 1 ).EQ.ZERO ) THEN
CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B, LDB )
ELSE
RANK = 1
CALL ZLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
D( 1 ) = ABS( D( 1 ) )
END IF
RETURN
END IF
*
* Rotate the matrix if it is lower bidiagonal.
*
IF( UPLO.EQ.'L' ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
IF( NRHS.EQ.1 ) THEN
CALL ZDROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
ELSE
RWORK( I*2-1 ) = CS
RWORK( I*2 ) = SN
END IF
10 CONTINUE
IF( NRHS.GT.1 ) THEN
DO 30 I = 1, NRHS
DO 20 J = 1, N - 1
CS = RWORK( J*2-1 )
SN = RWORK( J*2 )
CALL ZDROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
20 CONTINUE
30 CONTINUE
END IF
END IF
*
* Scale.
*
NM1 = N - 1
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO ) THEN
CALL ZLASET( 'A', N, NRHS, CZERO, CZERO, B, LDB )
RETURN
END IF
*
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
* If N is smaller than the minimum divide size SMLSIZ, then solve
* the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
IRWU = 1
IRWVT = IRWU + N*N
IRWWRK = IRWVT + N*N
IRWRB = IRWWRK
IRWIB = IRWRB + N*NRHS
IRWB = IRWIB + N*NRHS
CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWU ), N )
CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWVT ), N )
CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, RWORK( IRWVT ), N,
$ RWORK( IRWU ), N, RWORK( IRWWRK ), 1,
$ RWORK( IRWWRK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* In the real version, B is passed to DLASDQ and multiplied
* internally by Q**H. Here B is complex and that product is
* computed below in two steps (real and imaginary parts).
*
J = IRWB - 1
DO 50 JCOL = 1, NRHS
DO 40 JROW = 1, N
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
40 CONTINUE
50 CONTINUE
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
$ RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
J = IRWB - 1
DO 70 JCOL = 1, NRHS
DO 60 JROW = 1, N
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
60 CONTINUE
70 CONTINUE
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
$ RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
JREAL = IRWRB - 1
JIMAG = IRWIB - 1
DO 90 JCOL = 1, NRHS
DO 80 JROW = 1, N
JREAL = JREAL + 1
JIMAG = JIMAG + 1
B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
80 CONTINUE
90 CONTINUE
*
TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
DO 100 I = 1, N
IF( D( I ).LE.TOL ) THEN
CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
ELSE
CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
$ LDB, INFO )
RANK = RANK + 1
END IF
100 CONTINUE
*
* Since B is complex, the following call to DGEMM is performed
* in two steps (real and imaginary parts). That is for V * B
* (in the real version of the code V**H is stored in WORK).
*
* CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
* $ WORK( NWORK ), N )
*
J = IRWB - 1
DO 120 JCOL = 1, NRHS
DO 110 JROW = 1, N
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
110 CONTINUE
120 CONTINUE
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
$ RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
J = IRWB - 1
DO 140 JCOL = 1, NRHS
DO 130 JROW = 1, N
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
130 CONTINUE
140 CONTINUE
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
$ RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
JREAL = IRWRB - 1
JIMAG = IRWIB - 1
DO 160 JCOL = 1, NRHS
DO 150 JROW = 1, N
JREAL = JREAL + 1
JIMAG = JIMAG + 1
B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
150 CONTINUE
160 CONTINUE
*
* Unscale.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
END IF
*
* Book-keeping and setting up some constants.
*
NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
SMLSZP = SMLSIZ + 1
*
U = 1
VT = 1 + SMLSIZ*N
DIFL = VT + SMLSZP*N
DIFR = DIFL + NLVL*N
Z = DIFR + NLVL*N*2
C = Z + NLVL*N
S = C + N
POLES = S + N
GIVNUM = POLES + 2*NLVL*N
NRWORK = GIVNUM + 2*NLVL*N
BX = 1
*
IRWRB = NRWORK
IRWIB = IRWRB + SMLSIZ*NRHS
IRWB = IRWIB + SMLSIZ*NRHS
*
SIZEI = 1 + N
K = SIZEI + N
GIVPTR = K + N
PERM = GIVPTR + N
GIVCOL = PERM + NLVL*N
IWK = GIVCOL + NLVL*N*2
*
ST = 1
SQRE = 0
ICMPQ1 = 1
ICMPQ2 = 0
NSUB = 0
*
DO 170 I = 1, N
IF( ABS( D( I ) ).LT.EPS ) THEN
D( I ) = SIGN( EPS, D( I ) )
END IF
170 CONTINUE
*
DO 240 I = 1, NM1
IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
NSUB = NSUB + 1
IWORK( NSUB ) = ST
*
* Subproblem found. First determine its size and then
* apply divide and conquer on it.
*
IF( I.LT.NM1 ) THEN
*
* A subproblem with E(I) small for I < NM1.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
* A subproblem with E(NM1) not too small but I = NM1.
*
NSIZE = N - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
ELSE
*
* A subproblem with E(NM1) small. This implies an
* 1-by-1 subproblem at D(N), which is not solved
* explicitly.
*
NSIZE = I - ST + 1
IWORK( SIZEI+NSUB-1 ) = NSIZE
NSUB = NSUB + 1
IWORK( NSUB ) = N
IWORK( SIZEI+NSUB-1 ) = 1
CALL ZCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
END IF
ST1 = ST - 1
IF( NSIZE.EQ.1 ) THEN
*
* This is a 1-by-1 subproblem and is not solved
* explicitly.
*
CALL ZCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* This is a small subproblem and is solved by DLASDQ.
*
CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ RWORK( VT+ST1 ), N )
CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
$ RWORK( U+ST1 ), N )
CALL DLASDQ( 'U', 0, NSIZE, NSIZE, NSIZE, 0, D( ST ),
$ E( ST ), RWORK( VT+ST1 ), N, RWORK( U+ST1 ),
$ N, RWORK( NRWORK ), 1, RWORK( NRWORK ),
$ INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* In the real version, B is passed to DLASDQ and multiplied
* internally by Q**H. Here B is complex and that product is
* computed below in two steps (real and imaginary parts).
*
J = IRWB - 1
DO 190 JCOL = 1, NRHS
DO 180 JROW = ST, ST + NSIZE - 1
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
180 CONTINUE
190 CONTINUE
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
$ ZERO, RWORK( IRWRB ), NSIZE )
J = IRWB - 1
DO 210 JCOL = 1, NRHS
DO 200 JROW = ST, ST + NSIZE - 1
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
200 CONTINUE
210 CONTINUE
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
$ ZERO, RWORK( IRWIB ), NSIZE )
JREAL = IRWRB - 1
JIMAG = IRWIB - 1
DO 230 JCOL = 1, NRHS
DO 220 JROW = ST, ST + NSIZE - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
220 CONTINUE
230 CONTINUE
*
CALL ZLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
$ WORK( BX+ST1 ), N )
ELSE
*
* A large problem. Solve it using divide and conquer.
*
CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
$ E( ST ), RWORK( U+ST1 ), N, RWORK( VT+ST1 ),
$ IWORK( K+ST1 ), RWORK( DIFL+ST1 ),
$ RWORK( DIFR+ST1 ), RWORK( Z+ST1 ),
$ RWORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
$ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
$ RWORK( GIVNUM+ST1 ), RWORK( C+ST1 ),
$ RWORK( S+ST1 ), RWORK( NRWORK ),
$ IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
BXST = BX + ST1
CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
$ LDB, WORK( BXST ), N, RWORK( U+ST1 ), N,
$ RWORK( VT+ST1 ), IWORK( K+ST1 ),
$ RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
$ RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
$ RWORK( C+ST1 ), RWORK( S+ST1 ),
$ RWORK( NRWORK ), IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
ST = I + 1
END IF
240 CONTINUE
*
* Apply the singular values and treat the tiny ones as zero.
*
TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
*
DO 250 I = 1, N
*
* Some of the elements in D can be negative because 1-by-1
* subproblems were not solved explicitly.
*
IF( ABS( D( I ) ).LE.TOL ) THEN
CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, WORK( BX+I-1 ), N )
ELSE
RANK = RANK + 1
CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
$ WORK( BX+I-1 ), N, INFO )
END IF
D( I ) = ABS( D( I ) )
250 CONTINUE
*
* Now apply back the right singular vectors.
*
ICMPQ2 = 1
DO 320 I = 1, NSUB
ST = IWORK( I )
ST1 = ST - 1
NSIZE = IWORK( SIZEI+I-1 )
BXST = BX + ST1
IF( NSIZE.EQ.1 ) THEN
CALL ZCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
* Since B and BX are complex, the following call to DGEMM
* is performed in two steps (real and imaginary parts).
*
* CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
* $ B( ST, 1 ), LDB )
*
J = BXST - N - 1
JREAL = IRWB - 1
DO 270 JCOL = 1, NRHS
J = J + N
DO 260 JROW = 1, NSIZE
JREAL = JREAL + 1
RWORK( JREAL ) = DBLE( WORK( J+JROW ) )
260 CONTINUE
270 CONTINUE
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
$ RWORK( IRWRB ), NSIZE )
J = BXST - N - 1
JIMAG = IRWB - 1
DO 290 JCOL = 1, NRHS
J = J + N
DO 280 JROW = 1, NSIZE
JIMAG = JIMAG + 1
RWORK( JIMAG ) = DIMAG( WORK( J+JROW ) )
280 CONTINUE
290 CONTINUE
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
$ RWORK( IRWIB ), NSIZE )
JREAL = IRWRB - 1
JIMAG = IRWIB - 1
DO 310 JCOL = 1, NRHS
DO 300 JROW = ST, ST + NSIZE - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
300 CONTINUE
310 CONTINUE
ELSE
CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
$ B( ST, 1 ), LDB, RWORK( U+ST1 ), N,
$ RWORK( VT+ST1 ), IWORK( K+ST1 ),
$ RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
$ RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
$ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
$ IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
$ RWORK( C+ST1 ), RWORK( S+ST1 ),
$ RWORK( NRWORK ), IWORK( IWK ), INFO )
IF( INFO.NE.0 ) THEN
RETURN
END IF
END IF
320 CONTINUE
*
* Unscale and sort the singular values.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
CALL DLASRT( 'D', N, D, INFO )
CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
RETURN
*
* End of ZLALSD
*
END
*> \brief \b ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLALSA + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
* IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
* $ SMLSIZ
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
* $ K( * ), PERM( LDGCOL, * )
* DOUBLE PRECISION C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
* $ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
* $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
* COMPLEX*16 B( LDB, * ), BX( LDBX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLALSA is an itermediate step in solving the least squares problem
*> by computing the SVD of the coefficient matrix in compact form (The
*> singular vectors are computed as products of simple orthorgonal
*> matrices.).
*>
*> If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector
*> matrix of an upper bidiagonal matrix to the right hand side; and if
*> ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the
*> right hand side. The singular vector matrices were generated in
*> compact form by ZLALSA.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ICOMPQ
*> \verbatim
*> ICOMPQ is INTEGER
*> Specifies whether the left or the right singular vector
*> matrix is involved.
*> = 0: Left singular vector matrix
*> = 1: Right singular vector matrix
*> \endverbatim
*>
*> \param[in] SMLSIZ
*> \verbatim
*> SMLSIZ is INTEGER
*> The maximum size of the subproblems at the bottom of the
*> computation tree.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The row and column dimensions of the upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B and BX. NRHS must be at least 1.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension ( LDB, NRHS )
*> On input, B contains the right hand sides of the least
*> squares problem in rows 1 through M.
*> On output, B contains the solution X in rows 1 through N.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of B in the calling subprogram.
*> LDB must be at least max(1,MAX( M, N ) ).
*> \endverbatim
*>
*> \param[out] BX
*> \verbatim
*> BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
*> On exit, the result of applying the left or right singular
*> vector matrix to B.
*> \endverbatim
*>
*> \param[in] LDBX
*> \verbatim
*> LDBX is INTEGER
*> The leading dimension of BX.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*> U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
*> On entry, U contains the left singular vector matrices of all
*> subproblems at the bottom level.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER, LDU = > N.
*> The leading dimension of arrays U, VT, DIFL, DIFR,
*> POLES, GIVNUM, and Z.
*> \endverbatim
*>
*> \param[in] VT
*> \verbatim
*> VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
*> On entry, VT**H contains the right singular vector matrices of
*> all subproblems at the bottom level.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER array, dimension ( N ).
*> \endverbatim
*>
*> \param[in] DIFL
*> \verbatim
*> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
*> where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*> \endverbatim
*>
*> \param[in] DIFR
*> \verbatim
*> DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*> On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
*> distances between singular values on the I-th level and
*> singular values on the (I -1)-th level, and DIFR(*, 2 * I)
*> record the normalizing factors of the right singular vectors
*> matrices of subproblems on I-th level.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ).
*> On entry, Z(1, I) contains the components of the deflation-
*> adjusted updating row vector for subproblems on the I-th
*> level.
*> \endverbatim
*>
*> \param[in] POLES
*> \verbatim
*> POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*> On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
*> singular values involved in the secular equations on the I-th
*> level.
*> \endverbatim
*>
*> \param[in] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER array, dimension ( N ).
*> On entry, GIVPTR( I ) records the number of Givens
*> rotations performed on the I-th problem on the computation
*> tree.
*> \endverbatim
*>
*> \param[in] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
*> On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
*> locations of Givens rotations performed on the I-th level on
*> the computation tree.
*> \endverbatim
*>
*> \param[in] LDGCOL
*> \verbatim
*> LDGCOL is INTEGER, LDGCOL = > N.
*> The leading dimension of arrays GIVCOL and PERM.
*> \endverbatim
*>
*> \param[in] PERM
*> \verbatim
*> PERM is INTEGER array, dimension ( LDGCOL, NLVL ).
*> On entry, PERM(*, I) records permutations done on the I-th
*> level of the computation tree.
*> \endverbatim
*>
*> \param[in] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*> On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
*> values of Givens rotations performed on the I-th level on the
*> computation tree.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension ( N ).
*> On entry, if the I-th subproblem is not square,
*> C( I ) contains the C-value of a Givens rotation related to
*> the right null space of the I-th subproblem.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension ( N ).
*> On entry, if the I-th subproblem is not square,
*> S( I ) contains the S-value of a Givens rotation related to
*> the right null space of the I-th subproblem.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension at least
*> MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array.
*> The dimension must be at least 3 * N
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Ming Gu and Ren-Cang Li, Computer Science Division, University of
*> California at Berkeley, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*
* =====================================================================
SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
$ LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
$ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
$ IWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
$ SMLSIZ
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
$ K( * ), PERM( LDGCOL, * )
DOUBLE PRECISION C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
$ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
$ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
COMPLEX*16 B( LDB, * ), BX( LDBX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL,
$ JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML,
$ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLASDT, XERBLA, ZCOPY, ZLALS0
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( SMLSIZ.LT.3 ) THEN
INFO = -2
ELSE IF( N.LT.SMLSIZ ) THEN
INFO = -3
ELSE IF( NRHS.LT.1 ) THEN
INFO = -4
ELSE IF( LDB.LT.N ) THEN
INFO = -6
ELSE IF( LDBX.LT.N ) THEN
INFO = -8
ELSE IF( LDU.LT.N ) THEN
INFO = -10
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -19
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLALSA', -INFO )
RETURN
END IF
*
* Book-keeping and setting up the computation tree.
*
INODE = 1
NDIML = INODE + N
NDIMR = NDIML + N
*
CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
$ IWORK( NDIMR ), SMLSIZ )
*
* The following code applies back the left singular vector factors.
* For applying back the right singular vector factors, go to 170.
*
IF( ICOMPQ.EQ.1 ) THEN
GO TO 170
END IF
*
* The nodes on the bottom level of the tree were solved
* by DLASDQ. The corresponding left and right singular vector
* matrices are in explicit form. First apply back the left
* singular vector matrices.
*
NDB1 = ( ND+1 ) / 2
DO 130 I = NDB1, ND
*
* IC : center row of each node
* NL : number of rows of left subproblem
* NR : number of rows of right subproblem
* NLF: starting row of the left subproblem
* NRF: starting row of the right subproblem
*
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLF = IC - NL
NRF = IC + 1
*
* Since B and BX are complex, the following call to DGEMM
* is performed in two steps (real and imaginary parts).
*
* CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
*
J = NL*NRHS*2
DO 20 JCOL = 1, NRHS
DO 10 JROW = NLF, NLF + NL - 1
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
10 CONTINUE
20 CONTINUE
CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1 ), NL )
J = NL*NRHS*2
DO 40 JCOL = 1, NRHS
DO 30 JROW = NLF, NLF + NL - 1
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
30 CONTINUE
40 CONTINUE
CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
$ RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1+NL*NRHS ),
$ NL )
JREAL = 0
JIMAG = NL*NRHS
DO 60 JCOL = 1, NRHS
DO 50 JROW = NLF, NLF + NL - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
50 CONTINUE
60 CONTINUE
*
* Since B and BX are complex, the following call to DGEMM
* is performed in two steps (real and imaginary parts).
*
* CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
*
J = NR*NRHS*2
DO 80 JCOL = 1, NRHS
DO 70 JROW = NRF, NRF + NR - 1
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
70 CONTINUE
80 CONTINUE
CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1 ), NR )
J = NR*NRHS*2
DO 100 JCOL = 1, NRHS
DO 90 JROW = NRF, NRF + NR - 1
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
90 CONTINUE
100 CONTINUE
CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
$ RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1+NR*NRHS ),
$ NR )
JREAL = 0
JIMAG = NR*NRHS
DO 120 JCOL = 1, NRHS
DO 110 JROW = NRF, NRF + NR - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
110 CONTINUE
120 CONTINUE
*
130 CONTINUE
*
* Next copy the rows of B that correspond to unchanged rows
* in the bidiagonal matrix to BX.
*
DO 140 I = 1, ND
IC = IWORK( INODE+I-1 )
CALL ZCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
140 CONTINUE
*
* Finally go through the left singular vector matrices of all
* the other subproblems bottom-up on the tree.
*
J = 2**NLVL
SQRE = 0
*
DO 160 LVL = NLVL, 1, -1
LVL2 = 2*LVL - 1
*
* find the first node LF and last node LL on
* the current level LVL
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 150 I = LF, LL
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
J = J - 1
CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
$ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
$ INFO )
150 CONTINUE
160 CONTINUE
GO TO 330
*
* ICOMPQ = 1: applying back the right singular vector factors.
*
170 CONTINUE
*
* First now go through the right singular vector matrices of all
* the tree nodes top-down.
*
J = 0
DO 190 LVL = 1, NLVL
LVL2 = 2*LVL - 1
*
* Find the first node LF and last node LL on
* the current level LVL.
*
IF( LVL.EQ.1 ) THEN
LF = 1
LL = 1
ELSE
LF = 2**( LVL-1 )
LL = 2*LF - 1
END IF
DO 180 I = LL, LF, -1
IM1 = I - 1
IC = IWORK( INODE+IM1 )
NL = IWORK( NDIML+IM1 )
NR = IWORK( NDIMR+IM1 )
NLF = IC - NL
NRF = IC + 1
IF( I.EQ.LL ) THEN
SQRE = 0
ELSE
SQRE = 1
END IF
J = J + 1
CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
$ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
$ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
$ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
$ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
$ Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
$ INFO )
180 CONTINUE
190 CONTINUE
*
* The nodes on the bottom level of the tree were solved
* by DLASDQ. The corresponding right singular vector
* matrices are in explicit form. Apply them back.
*
NDB1 = ( ND+1 ) / 2
DO 320 I = NDB1, ND
I1 = I - 1
IC = IWORK( INODE+I1 )
NL = IWORK( NDIML+I1 )
NR = IWORK( NDIMR+I1 )
NLP1 = NL + 1
IF( I.EQ.ND ) THEN
NRP1 = NR
ELSE
NRP1 = NR + 1
END IF
NLF = IC - NL
NRF = IC + 1
*
* Since B and BX are complex, the following call to DGEMM is
* performed in two steps (real and imaginary parts).
*
* CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
*
J = NLP1*NRHS*2
DO 210 JCOL = 1, NRHS
DO 200 JROW = NLF, NLF + NLP1 - 1
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
200 CONTINUE
210 CONTINUE
CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, RWORK( 1 ),
$ NLP1 )
J = NLP1*NRHS*2
DO 230 JCOL = 1, NRHS
DO 220 JROW = NLF, NLF + NLP1 - 1
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
220 CONTINUE
230 CONTINUE
CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
$ RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO,
$ RWORK( 1+NLP1*NRHS ), NLP1 )
JREAL = 0
JIMAG = NLP1*NRHS
DO 250 JCOL = 1, NRHS
DO 240 JROW = NLF, NLF + NLP1 - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
240 CONTINUE
250 CONTINUE
*
* Since B and BX are complex, the following call to DGEMM is
* performed in two steps (real and imaginary parts).
*
* CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
*
J = NRP1*NRHS*2
DO 270 JCOL = 1, NRHS
DO 260 JROW = NRF, NRF + NRP1 - 1
J = J + 1
RWORK( J ) = DBLE( B( JROW, JCOL ) )
260 CONTINUE
270 CONTINUE
CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, RWORK( 1 ),
$ NRP1 )
J = NRP1*NRHS*2
DO 290 JCOL = 1, NRHS
DO 280 JROW = NRF, NRF + NRP1 - 1
J = J + 1
RWORK( J ) = DIMAG( B( JROW, JCOL ) )
280 CONTINUE
290 CONTINUE
CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
$ RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO,
$ RWORK( 1+NRP1*NRHS ), NRP1 )
JREAL = 0
JIMAG = NRP1*NRHS
DO 310 JCOL = 1, NRHS
DO 300 JROW = NRF, NRF + NRP1 - 1
JREAL = JREAL + 1
JIMAG = JIMAG + 1
BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
$ RWORK( JIMAG ) )
300 CONTINUE
310 CONTINUE
*
320 CONTINUE
*
330 CONTINUE
*
RETURN
*
* End of ZLALSA
*
END
*> \brief \b ZLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLALS0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
* POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
* $ LDGNUM, NL, NR, NRHS, SQRE
* DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( LDGCOL, * ), PERM( * )
* DOUBLE PRECISION DIFL( * ), DIFR( LDGNUM, * ),
* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
* $ RWORK( * ), Z( * )
* COMPLEX*16 B( LDB, * ), BX( LDBX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLALS0 applies back the multiplying factors of either the left or the
*> right singular vector matrix of a diagonal matrix appended by a row
*> to the right hand side matrix B in solving the least squares problem
*> using the divide-and-conquer SVD approach.
*>
*> For the left singular vector matrix, three types of orthogonal
*> matrices are involved:
*>
*> (1L) Givens rotations: the number of such rotations is GIVPTR; the
*> pairs of columns/rows they were applied to are stored in GIVCOL;
*> and the C- and S-values of these rotations are stored in GIVNUM.
*>
*> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
*> row, and for J=2:N, PERM(J)-th row of B is to be moved to the
*> J-th row.
*>
*> (3L) The left singular vector matrix of the remaining matrix.
*>
*> For the right singular vector matrix, four types of orthogonal
*> matrices are involved:
*>
*> (1R) The right singular vector matrix of the remaining matrix.
*>
*> (2R) If SQRE = 1, one extra Givens rotation to generate the right
*> null space.
*>
*> (3R) The inverse transformation of (2L).
*>
*> (4R) The inverse transformation of (1L).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ICOMPQ
*> \verbatim
*> ICOMPQ is INTEGER
*> Specifies whether singular vectors are to be computed in
*> factored form:
*> = 0: Left singular vector matrix.
*> = 1: Right singular vector matrix.
*> \endverbatim
*>
*> \param[in] NL
*> \verbatim
*> NL is INTEGER
*> The row dimension of the upper block. NL >= 1.
*> \endverbatim
*>
*> \param[in] NR
*> \verbatim
*> NR is INTEGER
*> The row dimension of the lower block. NR >= 1.
*> \endverbatim
*>
*> \param[in] SQRE
*> \verbatim
*> SQRE is INTEGER
*> = 0: the lower block is an NR-by-NR square matrix.
*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*>
*> The bidiagonal matrix has row dimension N = NL + NR + 1,
*> and column dimension M = N + SQRE.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of columns of B and BX. NRHS must be at least 1.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension ( LDB, NRHS )
*> On input, B contains the right hand sides of the least
*> squares problem in rows 1 through M. On output, B contains
*> the solution X in rows 1 through N.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of B. LDB must be at least
*> max(1,MAX( M, N ) ).
*> \endverbatim
*>
*> \param[out] BX
*> \verbatim
*> BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
*> \endverbatim
*>
*> \param[in] LDBX
*> \verbatim
*> LDBX is INTEGER
*> The leading dimension of BX.
*> \endverbatim
*>
*> \param[in] PERM
*> \verbatim
*> PERM is INTEGER array, dimension ( N )
*> The permutations (from deflation and sorting) applied
*> to the two blocks.
*> \endverbatim
*>
*> \param[in] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER
*> The number of Givens rotations which took place in this
*> subproblem.
*> \endverbatim
*>
*> \param[in] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 )
*> Each pair of numbers indicates a pair of rows/columns
*> involved in a Givens rotation.
*> \endverbatim
*>
*> \param[in] LDGCOL
*> \verbatim
*> LDGCOL is INTEGER
*> The leading dimension of GIVCOL, must be at least N.
*> \endverbatim
*>
*> \param[in] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
*> Each number indicates the C or S value used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[in] LDGNUM
*> \verbatim
*> LDGNUM is INTEGER
*> The leading dimension of arrays DIFR, POLES and
*> GIVNUM, must be at least K.
*> \endverbatim
*>
*> \param[in] POLES
*> \verbatim
*> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
*> On entry, POLES(1:K, 1) contains the new singular
*> values obtained from solving the secular equation, and
*> POLES(1:K, 2) is an array containing the poles in the secular
*> equation.
*> \endverbatim
*>
*> \param[in] DIFL
*> \verbatim
*> DIFL is DOUBLE PRECISION array, dimension ( K ).
*> On entry, DIFL(I) is the distance between I-th updated
*> (undeflated) singular value and the I-th (undeflated) old
*> singular value.
*> \endverbatim
*>
*> \param[in] DIFR
*> \verbatim
*> DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
*> On entry, DIFR(I, 1) contains the distances between I-th
*> updated (undeflated) singular value and the I+1-th
*> (undeflated) old singular value. And DIFR(I, 2) is the
*> normalizing factor for the I-th right singular vector.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( K )
*> Contain the components of the deflation-adjusted updating row
*> vector.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> Contains the dimension of the non-deflated matrix,
*> This is the order of the related secular equation. 1 <= K <=N.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> C contains garbage if SQRE =0 and the C-value of a Givens
*> rotation related to the right null space if SQRE = 1.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION
*> S contains garbage if SQRE =0 and the S-value of a Givens
*> rotation related to the right null space if SQRE = 1.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension
*> ( K*(1+NRHS) + 2*NRHS )
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Ming Gu and Ren-Cang Li, Computer Science Division, University of
*> California at Berkeley, USA \n
*> Osni Marques, LBNL/NERSC, USA \n
*
* =====================================================================
SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
$ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
*
* -- LAPACK computational routine (version 3.4.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012
*
* .. Scalar Arguments ..
INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
$ LDGNUM, NL, NR, NRHS, SQRE
DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
INTEGER GIVCOL( LDGCOL, * ), PERM( * )
DOUBLE PRECISION DIFL( * ), DIFR( LDGNUM, * ),
$ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
$ RWORK( * ), Z( * )
COMPLEX*16 B( LDB, * ), BX( LDBX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, NEGONE
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, JCOL, JROW, M, N, NLP1
DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, XERBLA, ZCOPY, ZDROT, ZDSCAL, ZLACPY,
$ ZLASCL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
INFO = -1
ELSE IF( NL.LT.1 ) THEN
INFO = -2
ELSE IF( NR.LT.1 ) THEN
INFO = -3
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
INFO = -4
END IF
*
N = NL + NR + 1
*
IF( NRHS.LT.1 ) THEN
INFO = -5
ELSE IF( LDB.LT.N ) THEN
INFO = -7
ELSE IF( LDBX.LT.N ) THEN
INFO = -9
ELSE IF( GIVPTR.LT.0 ) THEN
INFO = -11
ELSE IF( LDGCOL.LT.N ) THEN
INFO = -13
ELSE IF( LDGNUM.LT.N ) THEN
INFO = -15
ELSE IF( K.LT.1 ) THEN
INFO = -20
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLALS0', -INFO )
RETURN
END IF
*
M = N + SQRE
NLP1 = NL + 1
*
IF( ICOMPQ.EQ.0 ) THEN
*
* Apply back orthogonal transformations from the left.
*
* Step (1L): apply back the Givens rotations performed.
*
DO 10 I = 1, GIVPTR
CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ GIVNUM( I, 1 ) )
10 CONTINUE
*
* Step (2L): permute rows of B.
*
CALL ZCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
DO 20 I = 2, N
CALL ZCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
20 CONTINUE
*
* Step (3L): apply the inverse of the left singular vector
* matrix to BX.
*
IF( K.EQ.1 ) THEN
CALL ZCOPY( NRHS, BX, LDBX, B, LDB )
IF( Z( 1 ).LT.ZERO ) THEN
CALL ZDSCAL( NRHS, NEGONE, B, LDB )
END IF
ELSE
DO 100 J = 1, K
DIFLJ = DIFL( J )
DJ = POLES( J, 1 )
DSIGJ = -POLES( J, 2 )
IF( J.LT.K ) THEN
DIFRJ = -DIFR( J, 1 )
DSIGJP = -POLES( J+1, 2 )
END IF
IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
$ THEN
RWORK( J ) = ZERO
ELSE
RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
$ ( POLES( J, 2 )+DJ )
END IF
DO 30 I = 1, J - 1
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
RWORK( I ) = ZERO
ELSE
RWORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJ )-
$ DIFLJ ) / ( POLES( I, 2 )+DJ )
END IF
30 CONTINUE
DO 40 I = J + 1, K
IF( ( Z( I ).EQ.ZERO ) .OR.
$ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
RWORK( I ) = ZERO
ELSE
RWORK( I ) = POLES( I, 2 )*Z( I ) /
$ ( DLAMC3( POLES( I, 2 ), DSIGJP )+
$ DIFRJ ) / ( POLES( I, 2 )+DJ )
END IF
40 CONTINUE
RWORK( 1 ) = NEGONE
TEMP = DNRM2( K, RWORK, 1 )
*
* Since B and BX are complex, the following call to DGEMV
* is performed in two steps (real and imaginary parts).
*
* CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
* $ B( J, 1 ), LDB )
*
I = K + NRHS*2
DO 60 JCOL = 1, NRHS
DO 50 JROW = 1, K
I = I + 1
RWORK( I ) = DBLE( BX( JROW, JCOL ) )
50 CONTINUE
60 CONTINUE
CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
$ RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
I = K + NRHS*2
DO 80 JCOL = 1, NRHS
DO 70 JROW = 1, K
I = I + 1
RWORK( I ) = DIMAG( BX( JROW, JCOL ) )
70 CONTINUE
80 CONTINUE
CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
$ RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
DO 90 JCOL = 1, NRHS
B( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
$ RWORK( JCOL+K+NRHS ) )
90 CONTINUE
CALL ZLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
$ LDB, INFO )
100 CONTINUE
END IF
*
* Move the deflated rows of BX to B also.
*
IF( K.LT.MAX( M, N ) )
$ CALL ZLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
$ B( K+1, 1 ), LDB )
ELSE
*
* Apply back the right orthogonal transformations.
*
* Step (1R): apply back the new right singular vector matrix
* to B.
*
IF( K.EQ.1 ) THEN
CALL ZCOPY( NRHS, B, LDB, BX, LDBX )
ELSE
DO 180 J = 1, K
DSIGJ = POLES( J, 2 )
IF( Z( J ).EQ.ZERO ) THEN
RWORK( J ) = ZERO
ELSE
RWORK( J ) = -Z( J ) / DIFL( J ) /
$ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
END IF
DO 110 I = 1, J - 1
IF( Z( J ).EQ.ZERO ) THEN
RWORK( I ) = ZERO
ELSE
RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
$ 2 ) )-DIFR( I, 1 ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
110 CONTINUE
DO 120 I = J + 1, K
IF( Z( J ).EQ.ZERO ) THEN
RWORK( I ) = ZERO
ELSE
RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
$ 2 ) )-DIFL( I ) ) /
$ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
END IF
120 CONTINUE
*
* Since B and BX are complex, the following call to DGEMV
* is performed in two steps (real and imaginary parts).
*
* CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
* $ BX( J, 1 ), LDBX )
*
I = K + NRHS*2
DO 140 JCOL = 1, NRHS
DO 130 JROW = 1, K
I = I + 1
RWORK( I ) = DBLE( B( JROW, JCOL ) )
130 CONTINUE
140 CONTINUE
CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
$ RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
I = K + NRHS*2
DO 160 JCOL = 1, NRHS
DO 150 JROW = 1, K
I = I + 1
RWORK( I ) = DIMAG( B( JROW, JCOL ) )
150 CONTINUE
160 CONTINUE
CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
$ RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
DO 170 JCOL = 1, NRHS
BX( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
$ RWORK( JCOL+K+NRHS ) )
170 CONTINUE
180 CONTINUE
END IF
*
* Step (2R): if SQRE = 1, apply back the rotation that is
* related to the right null space of the subproblem.
*
IF( SQRE.EQ.1 ) THEN
CALL ZCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
CALL ZDROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
END IF
IF( K.LT.MAX( M, N ) )
$ CALL ZLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
$ LDBX )
*
* Step (3R): permute rows of B.
*
CALL ZCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
IF( SQRE.EQ.1 ) THEN
CALL ZCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
END IF
DO 190 I = 2, N
CALL ZCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
190 CONTINUE
*
* Step (4R): apply back the Givens rotations performed.
*
DO 200 I = GIVPTR, 1, -1
CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
$ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
$ -GIVNUM( I, 1 ) )
200 CONTINUE
END IF
*
RETURN
*
* End of ZLALS0
*
END