*> \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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dzsum1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dzsum1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dzsum1.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup sum1
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlc.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ilalc
*
* =====================================================================
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ilazlr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ilazlr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ilazlr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ilalr
*
* =====================================================================
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 first vector element of maximum absolute value.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IZMAX1 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/izmax1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/izmax1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/izmax1.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IZMAX1( N, ZX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IZMAX1 finds the index of the first vector element of 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 ZX.
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension (N)
*> The vector ZX. The IZMAX1 function returns the index of its first
*> element of maximum absolute value.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive values of ZX. INCX >= 1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup imax1
*
*> \par Contributors:
* ==================
*>
*> Nick Higham for use with ZLACON.
*
* =====================================================================
INTEGER FUNCTION IZMAX1( N, ZX, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DMAX
INTEGER I, IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IZMAX1 = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
IZMAX1 = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DMAX = ABS(ZX(1))
DO I = 2,N
IF (ABS(ZX(I)).GT.DMAX) THEN
IZMAX1 = I
DMAX = ABS(ZX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
DMAX = ABS(ZX(1))
IX = IX + INCX
DO I = 2,N
IF (ABS(ZX(IX)).GT.DMAX) THEN
IZMAX1 = I
DMAX = ABS(ZX(IX))
END IF
IX = IX + INCX
END DO
END IF
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zbdsqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zbdsqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zbdsqr.f">
*> [TXT]</a>
*> \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 (LRWORK)
*> LRWORK = 4*N, if NCVT = NRU = NCC = 0, and
*> LRWORK = 4*(N-1), 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
*
*> \par Note:
* ===========
*>
*> \verbatim
*> Bug report from Cezary Dendek.
*> On November 3rd 2023, the INTEGER variable MAXIT = MAXITR*N**2 is
*> removed since it can overflow pretty easily (for N larger or equal
*> than 18,919). We instead use MAXITDIVN = MAXITR*N.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup bdsqr
*
* =====================================================================
SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, ITERDIVN, J, LL, LLL, M,
$ MAXITDIVN, 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, 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
SMIN = 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.)
*
MAXITDIVN = MAXITR*N
ITERDIVN = 0
ITER = -1
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.GE.N ) THEN
ITER = ITER - N
ITERDIVN = ITERDIVN + 1
IF( ITERDIVN.GE.MAXITDIVN )
$ GO TO 200
END IF
*
* 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 ) )
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
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 ) )
SMIN = 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 ) ) ) )
SMIN = MIN( SMIN, 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 ) )
SMIN = 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 ) ) ) )
SMIN = MIN( SMIN, 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*( SMIN / 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 ).EQ.ZERO ) THEN
*
* Avoid -ZERO
*
D( I ) = ZERO
END IF
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zdrscl.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zdrscl.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zdrscl.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup rscl
*
* =====================================================================
SUBROUTINE ZDRSCL( N, SA, SX, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*
* 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 ZGBCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
* WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER INFO, KL, KU, LDAB, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 AB( LDAB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBCON estimates the reciprocal of the condition number of a complex
*> general band matrix A, in either the 1-norm or the infinity-norm,
*> using the LU factorization computed by ZGBTRF.
*>
*> 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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> Details of the LU factorization of the band matrix A, as
*> computed by ZGBTRF. U is stored as an upper triangular band
*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*> the multipliers used during the factorization are stored in
*> rows KL+KU+2 to 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= N, row i of the matrix was
*> interchanged with row IPIV(i).
*> \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 (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.
*
*> \ingroup gbcon
*
* =====================================================================
SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM,
$ RCOND,
$ WORK, RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, KL, KU, LDAB, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 AB( LDAB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, ONENRM
CHARACTER NORMIN
INTEGER IX, J, JP, KASE, KASE1, KD, LM
DOUBLE PRECISION AINVNM, SCALE, SMLNUM
COMPLEX*16 T, ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH
COMPLEX*16 ZDOTC
EXTERNAL LSAME, IZAMAX, DLAMCH, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZDRSCL, ZLACN2,
$ ZLATBS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MIN
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBCON', -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
KD = KL + KU + 1
LNOTI = KL.GT.0
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).
*
IF( LNOTI ) THEN
DO 20 J = 1, N - 1
LM = MIN( KL, N-J )
JP = IPIV( J )
T = WORK( JP )
IF( JP.NE.J ) THEN
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
CALL ZAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ),
$ 1 )
20 CONTINUE
END IF
*
* Multiply by inv(U).
*
CALL ZLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ KL+KU, AB, LDAB, WORK, SCALE, RWORK, INFO )
ELSE
*
* Multiply by inv(U**H).
*
CALL ZLATBS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, KL+KU, AB, LDAB, WORK, SCALE, RWORK,
$ INFO )
*
* Multiply by inv(L**H).
*
IF( LNOTI ) THEN
DO 30 J = N - 1, 1, -1
LM = MIN( KL, N-J )
WORK( J ) = WORK( J ) - ZDOTC( LM, AB( KD+1, J ),
$ 1,
$ WORK( J+1 ), 1 )
JP = IPIV( J )
IF( JP.NE.J ) THEN
T = WORK( JP )
WORK( JP ) = WORK( J )
WORK( J ) = T
END IF
30 CONTINUE
END IF
END IF
*
* Divide X by 1/SCALE if doing so will not cause overflow.
*
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 40
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
*
40 CONTINUE
RETURN
*
* End of ZGBCON
*
END
*> \brief \b ZGBEQU
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBEQU + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbequ.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbequ.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbequ.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
* AMAX, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, M, N
* DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), R( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBEQU computes row and column scalings intended to equilibrate an
*> M-by-N band matrix A and reduce its condition number. R returns the
*> row scale factors and C the column scale factors, chosen to try to
*> make the largest element in each row and column of the matrix B with
*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*>
*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
*> number and BIGNUM = largest safe number. Use of these scaling
*> factors is not guaranteed to reduce the condition number of A but
*> works well in practice.
*> \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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th
*> column of A is stored in the j-th column of the array AB as
*> follows:
*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KL+KU+1.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (M)
*> If INFO = 0, or INFO > M, R contains the row scale factors
*> for A.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, C contains the column scale factors for A.
*> \endverbatim
*>
*> \param[out] ROWCND
*> \verbatim
*> ROWCND is DOUBLE PRECISION
*> If INFO = 0 or INFO > M, ROWCND contains the ratio of the
*> smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
*> AMAX is neither too large nor too small, it is not worth
*> scaling by R.
*> \endverbatim
*>
*> \param[out] COLCND
*> \verbatim
*> COLCND is DOUBLE PRECISION
*> If INFO = 0, COLCND contains the ratio of the smallest
*> C(i) to the largest C(i). If COLCND >= 0.1, it is not
*> worth scaling by C.
*> \endverbatim
*>
*> \param[out] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix element. If AMAX is very
*> close to overflow or very close to underflow, the matrix
*> should be scaled.
*> \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, and i is
*> <= M: the i-th row of A is exactly zero
*> > M: the (i-M)-th column of A is exactly zero
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gbequ
*
* =====================================================================
SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND,
$ COLCND,
$ AMAX, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), R( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, KD
DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
COMPLEX*16 ZDUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
KD = KU + 1
DO 30 J = 1, N
DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
R( I ) = MAX( R( I ), CABS1( AB( KD+I-J, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
KD = KU + 1
DO 90 J = 1, N
DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
C( J ) = MAX( C( J ), CABS1( AB( KD+I-J, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of ZGBEQU
*
END
*> \brief \b ZGBRFS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBRFS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbrfs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbrfs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbrfs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBRFS improves the computed solution to a system of linear
*> equations when the coefficient matrix is banded, and provides
*> error bounds and backward error estimates for the solution.
*> \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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 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] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The original band matrix A, stored in rows 1 to KL+KU+1.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KL+KU+1.
*> \endverbatim
*>
*> \param[in] AFB
*> \verbatim
*> AFB is COMPLEX*16 array, dimension (LDAFB,N)
*> Details of the LU factorization of the band matrix A, as
*> computed by ZGBTRF. U is stored as an upper triangular band
*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*> the multipliers used during the factorization are stored in
*> rows KL+KU+2 to 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDAFB
*> \verbatim
*> LDAFB is INTEGER
*> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from ZGBTRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> On entry, the solution matrix X, as computed by ZGBTRS.
*> On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gbrfs
*
* =====================================================================
SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
$ LDAFB,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANSN, TRANST
INTEGER COUNT, I, J, K, KASE, KK, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZCOPY, ZGBMV, ZGBTRS,
$ ZLACN2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -7
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -9
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANSN = 'N'
TRANST = 'C'
ELSE
TRANSN = 'C'
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = MIN( KL+KU+2, N+1 )
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
CALL ZGBMV( TRANS, N, N, KL, KU, -CONE, AB, LDAB, X( 1, J ),
$ 1,
$ CONE, WORK, 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
RWORK( I ) = CABS1( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
KK = KU + 1 - K
XK = CABS1( X( K, J ) )
DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
RWORK( I ) = RWORK( I ) + CABS1( AB( KK+I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
KK = KU + 1 - K
DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
S = S + CABS1( AB( KK+I, K ) )*CABS1( X( I, J ) )
60 CONTINUE
RWORK( K ) = RWORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
ELSE
S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
$ ( RWORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL ZGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, WORK,
$ N,
$ INFO )
CALL ZAXPY( N, CONE, WORK, 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use ZLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
ELSE
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
$ SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**H).
*
CALL ZGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK, N, INFO )
DO 110 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
120 CONTINUE
CALL ZGBTRS( TRANSN, N, KL, KU, 1, AFB, LDAFB, IPIV,
$ WORK, N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of ZGBRFS
*
END
*> \brief <b> ZGBSV computes the solution to system of linear equations A * X = B for GB matrices</b> (simple driver)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBSV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbsv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbsv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbsv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBSV computes the solution to a complex system of linear equations
*> A * X = B, where A is a band matrix of order N with KL subdiagonals
*> and KU superdiagonals, 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 = L * U, where L is a product of permutation
*> and unit lower triangular matrices with KL subdiagonals, and U is
*> upper triangular with KL+KU superdiagonals. 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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 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] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \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 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, and the solution has not been computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gbsv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U because of fill-in resulting from the row interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
$ INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL XERBLA, ZGBTRF, ZGBTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( KL.LT.0 ) THEN
INFO = -2
ELSE IF( KU.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBSV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of the band matrix A.
*
CALL ZGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL ZGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB,
$ IPIV,
$ B, LDB, INFO )
END IF
RETURN
*
* End of ZGBSV
*
END
*> \brief <b> ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBSVX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbsvx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbsvx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbsvx.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
* RCOND, FERR, BERR, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER EQUED, FACT, TRANS
* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ),
* $ RWORK( * )
* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBSVX uses the LU factorization to compute the solution to a complex
*> system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
*> where A is a band matrix of order N with KL subdiagonals and KU
*> superdiagonals, and X and B are N-by-NRHS matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
* =================
*>
*> \verbatim
*>
*> The following steps are performed by this subroutine:
*>
*> 1. If FACT = 'E', real scaling factors are computed to equilibrate
*> the system:
*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
*> Whether or not the system will be equilibrated depends on the
*> scaling of the matrix A, but if equilibration is used, A is
*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
*> or diag(C)*B (if TRANS = 'T' or 'C').
*>
*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
*> matrix A (after equilibration if FACT = 'E') as
*> A = L * U,
*> where L is a product of permutation and unit lower triangular
*> matrices with KL subdiagonals, and U is upper triangular with
*> KL+KU superdiagonals.
*>
*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine
*> returns with INFO = i. Otherwise, the factored form of A is used
*> to estimate the condition number of the matrix A. If the
*> reciprocal of the condition number is less than machine precision,
*> INFO = N+1 is returned as a warning, but the routine still goes on
*> to solve for X and compute error bounds as described below.
*>
*> 4. The system of equations is solved for X using the factored form
*> of A.
*>
*> 5. Iterative refinement is applied to improve the computed solution
*> matrix and calculate error bounds and backward error estimates
*> for it.
*>
*> 6. If equilibration was used, the matrix X is premultiplied by
*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
*> that it solves the original system before equilibration.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] FACT
*> \verbatim
*> FACT is CHARACTER*1
*> Specifies whether or not the factored form of the matrix A is
*> supplied on entry, and if not, whether the matrix A should be
*> equilibrated before it is factored.
*> = 'F': On entry, AFB and IPIV contain the factored form of
*> A. If EQUED is not 'N', the matrix A has been
*> equilibrated with scaling factors given by R and C.
*> AB, AFB, and IPIV are not modified.
*> = 'N': The matrix A will be copied to AFB and factored.
*> = 'E': The matrix A will be equilibrated if necessary, then
*> copied to AFB and factored.
*> \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] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 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,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
*>
*> If FACT = 'F' and EQUED is not 'N', then A must have been
*> equilibrated by the scaling factors in R and/or C. AB is not
*> modified if FACT = 'F' or 'N', or if FACT = 'E' and
*> EQUED = 'N' on exit.
*>
*> On exit, if EQUED .ne. 'N', A is scaled as follows:
*> EQUED = 'R': A := diag(R) * A
*> EQUED = 'C': A := A * diag(C)
*> EQUED = 'B': A := diag(R) * A * diag(C).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KL+KU+1.
*> \endverbatim
*>
*> \param[in,out] AFB
*> \verbatim
*> AFB is COMPLEX*16 array, dimension (LDAFB,N)
*> If FACT = 'F', then AFB is an input argument and on entry
*> contains details of the LU factorization of the band matrix
*> A, as computed by ZGBTRF. U is stored as an upper triangular
*> band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
*> and the multipliers used during the factorization are stored
*> in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
*> the factored form of the equilibrated matrix A.
*>
*> If FACT = 'N', then AFB is an output argument and on exit
*> returns details of the LU factorization of A.
*>
*> If FACT = 'E', then AFB is an output argument and on exit
*> returns details of the LU factorization of the equilibrated
*> matrix A (see the description of AB for the form of the
*> equilibrated matrix).
*> \endverbatim
*>
*> \param[in] LDAFB
*> \verbatim
*> LDAFB is INTEGER
*> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in,out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> If FACT = 'F', then IPIV is an input argument and on entry
*> contains the pivot indices from the factorization A = L*U
*> as computed by ZGBTRF; row i of the matrix was interchanged
*> with row IPIV(i).
*>
*> If FACT = 'N', then IPIV is an output argument and on exit
*> contains the pivot indices from the factorization A = L*U
*> of the original matrix A.
*>
*> If FACT = 'E', then IPIV is an output argument and on exit
*> contains the pivot indices from the factorization A = L*U
*> of the equilibrated matrix A.
*> \endverbatim
*>
*> \param[in,out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies the form of equilibration that was done.
*> = 'N': No equilibration (always true if FACT = 'N').
*> = 'R': Row equilibration, i.e., A has been premultiplied by
*> diag(R).
*> = 'C': Column equilibration, i.e., A has been postmultiplied
*> by diag(C).
*> = 'B': Both row and column equilibration, i.e., A has been
*> replaced by diag(R) * A * diag(C).
*> EQUED is an input argument if FACT = 'F'; otherwise, it is an
*> output argument.
*> \endverbatim
*>
*> \param[in,out] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (N)
*> The row scale factors for A. If EQUED = 'R' or 'B', A is
*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
*> is not accessed. R is an input argument if FACT = 'F';
*> otherwise, R is an output argument. If FACT = 'F' and
*> EQUED = 'R' or 'B', each element of R must be positive.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> The column scale factors for A. If EQUED = 'C' or 'B', A is
*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
*> is not accessed. C is an input argument if FACT = 'F';
*> otherwise, C is an output argument. If FACT = 'F' and
*> EQUED = 'C' or 'B', each element of C must be positive.
*> \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 EQUED = 'N', B is not modified;
*> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
*> diag(R)*B;
*> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
*> overwritten by diag(C)*B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
*> to the original system of equations. Note that A and B are
*> modified on exit if EQUED .ne. 'N', and the solution to the
*> equilibrated system is inv(diag(C))*X if TRANS = 'N' and
*> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
*> and EQUED = 'R' or 'B'.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The estimate of the reciprocal condition number of the matrix
*> A after equilibration (if done). If RCOND is less than the
*> machine precision (in particular, if RCOND = 0), the matrix
*> is singular to working precision. This condition is
*> indicated by a return code of INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,N))
*> On exit, RWORK(1) contains the reciprocal pivot growth
*> factor norm(A)/norm(U). The "max absolute element" norm is
*> used. If RWORK(1) is much less than 1, then the stability
*> of the LU factorization of the (equilibrated) matrix A
*> could be poor. This also means that the solution X, condition
*> estimator RCOND, and forward error bound FERR could be
*> unreliable. If factorization fails with 0<INFO<=N, then
*> RWORK(1) contains the reciprocal pivot growth factor for the
*> leading INFO columns of A.
*> \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, and i is
*> <= N: U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, so the solution and error bounds
*> could not be computed. RCOND = 0 is returned.
*> = N+1: U is nonsingular, but RCOND is less than machine
*> precision, meaning that the matrix is singular
*> to working precision. Nevertheless, the
*> solution and error bounds are computed because
*> there are a number of situations where the
*> computed solution can be more accurate than the
*> value of RCOND would suggest.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gbsvx
*
* =====================================================================
SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
$ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
$ RCOND, FERR, BERR, WORK, RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ),
$ RWORK( * )
COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
* Moved setting of INFO = N+1 so INFO does not subsequently get
* overwritten. Sven, 17 Mar 05.
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J, J1, J2
DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANGB, ZLANTB
EXTERNAL LSAME, DLAMCH, ZLANGB, ZLANTB
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZGBCON, ZGBEQU, ZGBRFS,
$ ZGBTRF,
$ ZGBTRS, ZLACPY, ZLAQGB
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND.
$ .NOT.EQUIL .AND.
$ .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( KL.LT.0 ) THEN
INFO = -4
ELSE IF( KU.LT.0 ) THEN
INFO = -5
ELSE IF( NRHS.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KL+KU+1 ) THEN
INFO = -8
ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
INFO = -10
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -12
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -13
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -14
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -16
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -18
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL ZGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
$ AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL ZLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND,
$ COLCND,
$ AMAX, EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of the band matrix A.
*
DO 70 J = 1, N
J1 = MAX( J-KU, 1 )
J2 = MIN( J+KL, N )
CALL ZCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
$ AFB( KL+KU+1-J+J1, J ), 1 )
70 CONTINUE
*
CALL ZGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
ANORM = ZERO
DO 90 J = 1, INFO
DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
80 CONTINUE
90 CONTINUE
RPVGRW = ZLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1,
$ KL+KU ),
$ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
$ RWORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ANORM / RPVGRW
END IF
RWORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = ZLANGB( NORM, N, KL, KU, AB, LDAB, RWORK )
RPVGRW = ZLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, RWORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ZLANGB( 'M', N, KL, KU, AB, LDAB, RWORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL ZGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
$ WORK, RWORK, INFO )
*
* Compute the solution matrix X.
*
CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL ZGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
$ IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = C( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
120 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 140 J = 1, NRHS
DO 130 I = 1, N
X( I, J ) = R( I )*X( I, J )
130 CONTINUE
140 CONTINUE
DO 150 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
150 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RWORK( 1 ) = RPVGRW
RETURN
*
* End of ZGBSVX
*
END
*> \brief \b ZGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTF2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbtf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbtf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbtf2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
*> A using partial pivoting with row interchanges.
*>
*> This is the unblocked version of the algorithm, calling Level 2 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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \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.
*
*> \ingroup gbtf2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U, because of fill-in resulting from the row
*> interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. 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, JP, JU, KM, KV
* ..
* .. External Functions ..
INTEGER IZAMAX
EXTERNAL IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in.
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero.
*
DO 20 J = KU + 2, MIN( KV, N )
DO 10 I = KV - J + 2, KL
AB( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* JU is the index of the last column affected by the current stage
* of the factorization.
*
JU = 1
*
DO 40 J = 1, MIN( M, N )
*
* Set fill-in elements in column J+KV to zero.
*
IF( J+KV.LE.N ) THEN
DO 30 I = 1, KL
AB( I, J+KV ) = ZERO
30 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-J )
JP = IZAMAX( KM+1, AB( KV+1, J ), 1 )
IPIV( J ) = JP + J - 1
IF( AB( KV+JP, J ).NE.ZERO ) THEN
JU = MAX( JU, MIN( J+KU+JP-1, N ) )
*
* Apply interchange to columns J to JU.
*
IF( JP.NE.1 )
$ CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
$ AB( KV+1, J ), LDAB-1 )
IF( KM.GT.0 ) THEN
*
* Compute multipliers.
*
CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ),
$ 1 )
*
* Update trailing submatrix within the band.
*
IF( JU.GT.J )
$ CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,
$ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
$ LDAB-1 )
END IF
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = J
END IF
40 CONTINUE
RETURN
*
* End of ZGBTF2
*
END
*> \brief \b ZGBTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbtrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbtrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbtrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
*> using partial pivoting with row interchanges.
*>
*> This is the blocked version of the algorithm, calling 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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows KL+1 to
*> 2*KL+KU+1; rows 1 to KL of the array need not be set.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*> On exit, details of the factorization: U is stored as an
*> upper triangular band matrix with KL+KU superdiagonals in
*> rows 1 to KL+KU+1, and the multipliers used during the
*> factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*> See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \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.
*
*> \ingroup gbtrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> M = N = 6, KL = 2, KU = 1:
*>
*> On entry: On exit:
*>
*> * * * + + + * * * u14 u25 u36
*> * * + + + + * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*> a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
*> a31 a42 a53 a64 * * m31 m42 m53 m64 * *
*>
*> Array elements marked * are not used by the routine; elements marked
*> + need not be set on entry, but are required by the routine to store
*> elements of U because of fill-in resulting from the row interchanges.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, KL, KU, LDAB, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
$ JU, K2, KM, KV, NB, NW
COMPLEX*16 TEMP
* ..
* .. Local Arrays ..
COMPLEX*16 WORK13( LDWORK, NBMAX ),
$ WORK31( LDWORK, NBMAX )
* ..
* .. External Functions ..
INTEGER ILAENV, IZAMAX
EXTERNAL ILAENV, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU,
$ ZLASWP,
$ ZSCAL, ZSWAP, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* KV is the number of superdiagonals in the factor U, allowing for
* fill-in
*
KV = KU + KL
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( LDAB.LT.KL+KV+1 ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTRF', -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, 'ZGBTRF', ' ', M, N, KL, KU )
*
* The block size must not exceed the limit set by the size of the
* local arrays WORK13 and WORK31.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KL ) THEN
*
* Use unblocked code
*
CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
ELSE
*
* Use blocked code
*
* Zero the superdiagonal elements of the work array WORK13
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK13( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Zero the subdiagonal elements of the work array WORK31
*
DO 40 J = 1, NB
DO 30 I = J + 1, NB
WORK31( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Gaussian elimination with partial pivoting
*
* Set fill-in elements in columns KU+2 to KV to zero
*
DO 60 J = KU + 2, MIN( KV, N )
DO 50 I = KV - J + 2, KL
AB( I, J ) = ZERO
50 CONTINUE
60 CONTINUE
*
* JU is the index of the last column affected by the current
* stage of the factorization
*
JU = 1
*
DO 180 J = 1, MIN( M, N ), NB
JB = MIN( NB, MIN( M, N )-J+1 )
*
* The active part of the matrix is partitioned
*
* A11 A12 A13
* A21 A22 A23
* A31 A32 A33
*
* Here A11, A21 and A31 denote the current block of JB columns
* which is about to be factorized. The number of rows in the
* partitioning are JB, I2, I3 respectively, and the numbers
* of columns are JB, J2, J3. The superdiagonal elements of A13
* and the subdiagonal elements of A31 lie outside the band.
*
I2 = MIN( KL-JB, M-J-JB+1 )
I3 = MIN( JB, M-J-KL+1 )
*
* J2 and J3 are computed after JU has been updated.
*
* Factorize the current block of JB columns
*
DO 80 JJ = J, J + JB - 1
*
* Set fill-in elements in column JJ+KV to zero
*
IF( JJ+KV.LE.N ) THEN
DO 70 I = 1, KL
AB( I, JJ+KV ) = ZERO
70 CONTINUE
END IF
*
* Find pivot and test for singularity. KM is the number of
* subdiagonal elements in the current column.
*
KM = MIN( KL, M-JJ )
JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
IPIV( JJ ) = JP + JJ - J
IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to J+JB-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange affects columns J to JJ-1 of A31
* which are stored in the work array WORK31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
$ AB( KV+JP, JJ ), LDAB-1 )
END IF
END IF
*
* Compute multipliers
*
CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2,
$ JJ ),
$ 1 )
*
* Update trailing submatrix within the band and within
* the current block. JM is the index of the last column
* which needs to be updated.
*
JM = MIN( JU, J+JB-1 )
IF( JM.GT.JJ )
$ CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
$ AB( KV, JJ+1 ), LDAB-1,
$ AB( KV+1, JJ+1 ), LDAB-1 )
ELSE
*
* If pivot is zero, set INFO to the index of the pivot
* unless a zero pivot has already been found.
*
IF( INFO.EQ.0 )
$ INFO = JJ
END IF
*
* Copy current column of A31 into the work array WORK31
*
NW = MIN( JJ-J+1, I3 )
IF( NW.GT.0 )
$ CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
$ WORK31( 1, JJ-J+1 ), 1 )
80 CONTINUE
IF( J+JB.LE.N ) THEN
*
* Apply the row interchanges to the other blocks.
*
J2 = MIN( JU-J+1, KV ) - JB
J3 = MAX( 0, JU-J-KV+1 )
*
* Use ZLASWP to apply the row interchanges to A12, A22, and
* A32.
*
CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
$ IPIV( J ), 1 )
*
* Adjust the pivot indices.
*
DO 90 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
90 CONTINUE
*
* Apply the row interchanges to A13, A23, and A33
* columnwise.
*
K2 = J - 1 + JB + J2
DO 110 I = 1, J3
JJ = K2 + I
DO 100 II = J + I - 1, J + JB - 1
IP = IPIV( II )
IF( IP.NE.II ) THEN
TEMP = AB( KV+1+II-JJ, JJ )
AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
AB( KV+1+IP-JJ, JJ ) = TEMP
END IF
100 CONTINUE
110 CONTINUE
*
* Update the relevant part of the trailing submatrix
*
IF( J2.GT.0 ) THEN
*
* Update A12
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose',
$ 'Unit',
$ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1 )
*
IF( I2.GT.0 ) THEN
*
* Update A22
*
CALL ZGEMM( 'No transpose', 'No transpose', I2,
$ J2,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+1, J+JB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A32
*
CALL ZGEMM( 'No transpose', 'No transpose', I3,
$ J2,
$ JB, -ONE, WORK31, LDWORK,
$ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
$ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
END IF
END IF
*
IF( J3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array
* WORK13
*
DO 130 JJ = 1, J3
DO 120 II = JJ, JB
WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
120 CONTINUE
130 CONTINUE
*
* Update A13 in the work array
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose',
$ 'Unit',
$ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
$ WORK13, LDWORK )
*
IF( I2.GT.0 ) THEN
*
* Update A23
*
CALL ZGEMM( 'No transpose', 'No transpose', I2,
$ J3,
$ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
$ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
$ LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Update A33
*
CALL ZGEMM( 'No transpose', 'No transpose', I3,
$ J3,
$ JB, -ONE, WORK31, LDWORK, WORK13,
$ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
END IF
*
* Copy the lower triangle of A13 back into place
*
DO 150 JJ = 1, J3
DO 140 II = JJ, JB
AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
140 CONTINUE
150 CONTINUE
END IF
ELSE
*
* Adjust the pivot indices.
*
DO 160 I = J, J + JB - 1
IPIV( I ) = IPIV( I ) + J - 1
160 CONTINUE
END IF
*
* Partially undo the interchanges in the current block to
* restore the upper triangular form of A31 and copy the upper
* triangle of A31 back into place
*
DO 170 JJ = J + JB - 1, J, -1
JP = IPIV( JJ ) - JJ + 1
IF( JP.NE.1 ) THEN
*
* Apply interchange to columns J to JJ-1
*
IF( JP+JJ-1.LT.J+KL ) THEN
*
* The interchange does not affect A31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
ELSE
*
* The interchange does affect A31
*
CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
$ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
END IF
END IF
*
* Copy the current column of A31 back into place
*
NW = MIN( I3, JJ-J+1 )
IF( NW.GT.0 )
$ CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
$ AB( KV+KL+1-JJ+J, JJ ), 1 )
170 CONTINUE
180 CONTINUE
END IF
*
RETURN
*
* End of ZGBTRF
*
END
*> \brief \b ZGBTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGBTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgbtrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgbtrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgbtrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGBTRS solves a system of linear equations
*> A * X = B, A**T * X = B, or A**H * X = B
*> with a general band matrix A using the LU factorization computed
*> by ZGBTRF.
*> \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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 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] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> Details of the LU factorization of the band matrix A, as
*> computed by ZGBTRF. U is stored as an upper triangular band
*> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*> the multipliers used during the factorization are stored in
*> rows KL+KU+2 to 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; 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.
*
*> \ingroup gbtrs
*
* =====================================================================
SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B,
$ LDB,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AB( LDAB, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LNOTI, NOTRAN
INTEGER I, J, KD, L, LM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP,
$ ZTBSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. 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( KL.LT.0 ) THEN
INFO = -3
ELSE IF( KU.LT.0 ) THEN
INFO = -4
ELSE IF( NRHS.LT.0 ) THEN
INFO = -5
ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGBTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
KD = KU + KL + 1
LNOTI = KL.GT.0
*
IF( NOTRAN ) THEN
*
* Solve A*X = B.
*
* Solve L*X = B, overwriting B with X.
*
* L is represented as a product of permutations and unit lower
* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
* where each transformation L(i) is a rank-one modification of
* the identity matrix.
*
IF( LNOTI ) THEN
DO 10 J = 1, N - 1
LM = MIN( KL, N-J )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J,
$ 1 ),
$ LDB, B( J+1, 1 ), LDB )
10 CONTINUE
END IF
*
DO 20 I = 1, NRHS
*
* Solve U*X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N,
$ KL+KU,
$ AB, LDAB, B( 1, I ), 1 )
20 CONTINUE
*
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Solve A**T * X = B.
*
DO 30 I = 1, NRHS
*
* Solve U**T * X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU,
$ AB,
$ LDAB, B( 1, I ), 1 )
30 CONTINUE
*
* Solve L**T * X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 40 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
$ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
40 CONTINUE
END IF
*
ELSE
*
* Solve A**H * X = B.
*
DO 50 I = 1, NRHS
*
* Solve U**H * X = B, overwriting B with X.
*
CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit',
$ N,
$ KL+KU, AB, LDAB, B( 1, I ), 1 )
50 CONTINUE
*
* Solve L**H * X = B, overwriting B with X.
*
IF( LNOTI ) THEN
DO 60 J = N - 1, 1, -1
LM = MIN( KL, N-J )
CALL ZLACGV( NRHS, B( J, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
$ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
$ B( J, 1 ), LDB )
CALL ZLACGV( NRHS, B( J, 1 ), LDB )
L = IPIV( J )
IF( L.NE.J )
$ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
60 CONTINUE
END IF
END IF
RETURN
*
* End of ZGBTRS
*
END
*> \brief \b ZGEBAK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebak.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebak.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebak.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup gebak
*
* =====================================================================
SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 = INT( 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 = INT( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebal.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebal.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebal.f">
*> [TXT]</a>
*> \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
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*> IHI is INTEGER
*> ILO and IHI are set to integers 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.
*
*> \ingroup gebal
*
*> \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
*>
*> Refactored by Evert Provoost, Department of Computer Science,
*> KU Leuven, Belgium
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, CANSWAP
INTEGER I, ICA, IRA, J, K, L
DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
$ SFMIN2
* ..
* .. 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
*
* 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
*
* Quick returns.
*
IF( N.EQ.0 ) THEN
ILO = 1
IHI = 0
RETURN
END IF
*
IF( LSAME( JOB, 'N' ) ) THEN
DO I = 1, N
SCALE( I ) = ONE
END DO
ILO = 1
IHI = N
RETURN
END IF
*
* Permutation to isolate eigenvalues if possible.
*
K = 1
L = N
*
IF( .NOT.LSAME( JOB, 'S' ) ) THEN
*
* Row and column exchange.
*
NOCONV = .TRUE.
DO WHILE( NOCONV )
*
* Search for rows isolating an eigenvalue and push them down.
*
NOCONV = .FALSE.
DO I = L, 1, -1
CANSWAP = .TRUE.
DO J = 1, L
IF( I.NE.J .AND. ( DBLE( A( I, J ) ).NE.ZERO .OR.
$ DIMAG( A( I, J ) ).NE.ZERO ) ) THEN
CANSWAP = .FALSE.
EXIT
END IF
END DO
*
IF( CANSWAP ) THEN
SCALE( L ) = I
IF( I.NE.L ) THEN
CALL ZSWAP( L, A( 1, I ), 1, A( 1, L ), 1 )
CALL ZSWAP( N-K+1, A( I, K ), LDA, A( L, K ),
$ LDA )
END IF
NOCONV = .TRUE.
*
IF( L.EQ.1 ) THEN
ILO = 1
IHI = 1
RETURN
END IF
*
L = L - 1
END IF
END DO
*
END DO
NOCONV = .TRUE.
DO WHILE( NOCONV )
*
* Search for columns isolating an eigenvalue and push them left.
*
NOCONV = .FALSE.
DO J = K, L
CANSWAP = .TRUE.
DO I = K, L
IF( I.NE.J .AND. ( DBLE( A( I, J ) ).NE.ZERO .OR.
$ DIMAG( A( I, J ) ).NE.ZERO ) ) THEN
CANSWAP = .FALSE.
EXIT
END IF
END DO
*
IF( CANSWAP ) THEN
SCALE( K ) = J
IF( J.NE.K ) THEN
CALL ZSWAP( L, A( 1, J ), 1, A( 1, K ), 1 )
CALL ZSWAP( N-K+1, A( J, K ), LDA, A( K, K ),
$ LDA )
END IF
NOCONV = .TRUE.
*
K = K + 1
END IF
END DO
*
END DO
*
END IF
*
* Initialize SCALE for non-permuted submatrix.
*
DO I = K, L
SCALE( I ) = ONE
END DO
*
* If we only had to permute, we are done.
*
IF( LSAME( JOB, 'P' ) ) THEN
ILO = K
IHI = L
RETURN
END IF
*
* 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
*
NOCONV = .TRUE.
DO WHILE( NOCONV )
NOCONV = .FALSE.
*
DO 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 ) CYCLE
*
* Exit if NaN to avoid infinite loop
*
IF( DISNAN( C+CA+R+RA ) ) THEN
INFO = -3
CALL XERBLA( 'ZGEBAL', -INFO )
RETURN
END IF
*
G = R / SCLFAC
F = ONE
S = C + R
*
DO WHILE( C.LT.G .AND. MAX( F, C, CA ).LT.SFMAX2 .AND.
$ MIN( R, G, RA ).GT.SFMIN2 )
F = F*SCLFAC
C = C*SCLFAC
CA = CA*SCLFAC
R = R / SCLFAC
G = G / SCLFAC
RA = RA / SCLFAC
END DO
*
G = C / SCLFAC
*
DO WHILE( G.GE.R .AND. MAX( R, RA ).LT.SFMAX2 .AND.
$ MIN( F, C, G, CA ).GT.SFMIN2 )
F = F / SCLFAC
C = C / SCLFAC
G = G / SCLFAC
CA = CA / SCLFAC
R = R*SCLFAC
RA = RA*SCLFAC
END DO
*
* Now balance.
*
IF( ( C+R ).GE.FACTOR*S ) CYCLE
IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
IF( F*SCALE( I ).LE.SFMIN1 ) CYCLE
END IF
IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
IF( SCALE( I ).GE.SFMAX1 / F ) CYCLE
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 )
*
END DO
*
END DO
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebd2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebd2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebd2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup gebd2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF1F, 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 ) = DBLE( ALPHA )
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL ZLARF1F( '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 ) = DBLE( ALPHA )
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL ZLARF1F( '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 ) = DBLE( ALPHA )
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL ZLARF1F( '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 ) = DBLE( ALPHA )
*
* Apply H(i)**H to A(i+1:m,i+1:n) from the left
*
CALL ZLARF1F( '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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgebrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgebrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgebrd.f">
*> [TXT]</a>
*> \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 >= 1, if MIN(M,N) = 0, and LWORK >= MAX(M,N), otherwise.
*> 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.
*
*> \ingroup gebrd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, LWKMIN, LWKOPT,
$ MINMN, NB, NBMIN, NX, 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
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
LWKMIN = 1
LWKOPT = 1
ELSE
LWKMIN = MAX( M, N )
NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
LWKOPT = ( M+N )*NB
END IF
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.LWKMIN .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
*
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 = LWKOPT
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgecon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgecon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgecon.f">
*> [TXT]</a>
*> \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.
*> NaNs are illegal values for ANORM, and they propagate to
*> the output parameter RCOND.
*> Infinity is illegal for ANORM, and it propagates to the output
*> parameter RCOND as 0.
*> = 1: if RCOND = NaN, or
*> RCOND = Inf, or
*> the computed norm of the inverse of A is 0.
*> In the latter, RCOND = 0 is returned.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gecon
*
* =====================================================================
SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, HUGEVAL
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IZAMAX, DLAMCH, DISNAN
* ..
* .. 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 ..
*
HUGEVAL = DLAMCH( 'Overflow' )
*
* 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
ELSE IF( DISNAN( ANORM ) ) THEN
RCOND = ANORM
INFO = -5
RETURN
ELSE IF( ANORM.GT.HUGEVAL ) THEN
INFO = -5
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 ) THEN
RCOND = ( ONE / AINVNM ) / ANORM
ELSE
INFO = 1
RETURN
END IF
*
* Check for NaNs and Infs
*
IF( DISNAN( RCOND ) .OR. RCOND.GT.HUGEVAL )
$ INFO = 1
*
20 CONTINUE
RETURN
*
* End of ZGECON
*
END
*> \brief \b ZGEEQU
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEQU + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeequ.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeequ.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeequ.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), R( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEEQU computes row and column scalings intended to equilibrate an
*> M-by-N matrix A and reduce its condition number. R returns the row
*> scale factors and C the column scale factors, chosen to try to make
*> the largest element in each row and column of the matrix B with
*> elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*>
*> R(i) and C(j) are restricted to be between SMLNUM = smallest safe
*> number and BIGNUM = largest safe number. Use of these scaling
*> factors is not guaranteed to reduce the condition number of A but
*> works well in practice.
*> \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] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The M-by-N matrix whose equilibration factors are
*> to be computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (M)
*> If INFO = 0 or INFO > M, R contains the row scale factors
*> for A.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, C contains the column scale factors for A.
*> \endverbatim
*>
*> \param[out] ROWCND
*> \verbatim
*> ROWCND is DOUBLE PRECISION
*> If INFO = 0 or INFO > M, ROWCND contains the ratio of the
*> smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
*> AMAX is neither too large nor too small, it is not worth
*> scaling by R.
*> \endverbatim
*>
*> \param[out] COLCND
*> \verbatim
*> COLCND is DOUBLE PRECISION
*> If INFO = 0, COLCND contains the ratio of the smallest
*> C(i) to the largest C(i). If COLCND >= 0.1, it is not
*> worth scaling by C.
*> \endverbatim
*>
*> \param[out] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix element. If AMAX is very
*> close to overflow or very close to underflow, the matrix
*> should be scaled.
*> \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, and i is
*> <= M: the i-th row of A is exactly zero
*> > M: the (i-M)-th column of A is exactly zero
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup geequ
*
* =====================================================================
SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), R( * )
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 BIGNUM, RCMAX, RCMIN, SMLNUM
COMPLEX*16 ZDUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. 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( 'ZGEEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
ROWCND = ONE
COLCND = ONE
AMAX = ZERO
RETURN
END IF
*
* Get machine constants.
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Compute row scale factors.
*
DO 10 I = 1, M
R( I ) = ZERO
10 CONTINUE
*
* Find the maximum element in each row.
*
DO 30 J = 1, N
DO 20 I = 1, M
R( I ) = MAX( R( I ), CABS1( A( I, J ) ) )
20 CONTINUE
30 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 40 I = 1, M
RCMAX = MAX( RCMAX, R( I ) )
RCMIN = MIN( RCMIN, R( I ) )
40 CONTINUE
AMAX = RCMAX
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 50 I = 1, M
IF( R( I ).EQ.ZERO ) THEN
INFO = I
RETURN
END IF
50 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 60 I = 1, M
R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
60 CONTINUE
*
* Compute ROWCND = min(R(I)) / max(R(I))
*
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
* Compute column scale factors
*
DO 70 J = 1, N
C( J ) = ZERO
70 CONTINUE
*
* Find the maximum element in each column,
* assuming the row scaling computed above.
*
DO 90 J = 1, N
DO 80 I = 1, M
C( J ) = MAX( C( J ), CABS1( A( I, J ) )*R( I ) )
80 CONTINUE
90 CONTINUE
*
* Find the maximum and minimum scale factors.
*
RCMIN = BIGNUM
RCMAX = ZERO
DO 100 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
100 CONTINUE
*
IF( RCMIN.EQ.ZERO ) THEN
*
* Find the first zero scale factor and return an error code.
*
DO 110 J = 1, N
IF( C( J ).EQ.ZERO ) THEN
INFO = M + J
RETURN
END IF
110 CONTINUE
ELSE
*
* Invert the scale factors.
*
DO 120 J = 1, N
C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
120 CONTINUE
*
* Compute COLCND = min(C(J)) / max(C(J))
*
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
END IF
*
RETURN
*
* End of ZGEEQU
*
END
*> \brief <b> ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEES + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgees.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgees.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgees.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
* LDVS, WORK, LWORK, RWORK, BWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVS, SORT
* INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
* LOGICAL BWORK( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
* ..
* .. Function Arguments ..
* LOGICAL SELECT
* EXTERNAL SELECT
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues, the Schur form T, and, optionally, the matrix of Schur
*> vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
*>
*> Optionally, it also orders the eigenvalues on the diagonal of the
*> Schur form so that selected eigenvalues are at the top left.
*> The leading columns of Z then form an orthonormal basis for the
*> invariant subspace corresponding to the selected eigenvalues.
*>
*> A complex matrix is in Schur form if it is upper triangular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVS
*> \verbatim
*> JOBVS is CHARACTER*1
*> = 'N': Schur vectors are not computed;
*> = 'V': Schur vectors are computed.
*> \endverbatim
*>
*> \param[in] SORT
*> \verbatim
*> SORT is CHARACTER*1
*> Specifies whether or not to order the eigenvalues on the
*> diagonal of the Schur form.
*> = 'N': Eigenvalues are not ordered:
*> = 'S': Eigenvalues are ordered (see SELECT).
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument
*> SELECT must be declared EXTERNAL in the calling subroutine.
*> If SORT = 'S', SELECT is used to select eigenvalues to order
*> to the top left of the Schur form.
*> IF SORT = 'N', SELECT is not referenced.
*> The eigenvalue W(j) is selected if SELECT(W(j)) is true.
*> \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 by its Schur form T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] SDIM
*> \verbatim
*> SDIM is INTEGER
*> If SORT = 'N', SDIM = 0.
*> If SORT = 'S', SDIM = number of eigenvalues for which
*> SELECT is true.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> W contains the computed eigenvalues, in the same order that
*> they appear on the diagonal of the output Schur form T.
*> \endverbatim
*>
*> \param[out] VS
*> \verbatim
*> VS is COMPLEX*16 array, dimension (LDVS,N)
*> If JOBVS = 'V', VS contains the unitary matrix Z of Schur
*> vectors.
*> If JOBVS = 'N', VS is not referenced.
*> \endverbatim
*>
*> \param[in] LDVS
*> \verbatim
*> LDVS is INTEGER
*> The leading dimension of the array VS. LDVS >= 1; if
*> JOBVS = 'V', LDVS >= 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 (N)
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*> BWORK is LOGICAL array, dimension (N)
*> Not referenced if SORT = '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, and i is
*> <= N: the QR algorithm failed to compute all the
*> eigenvalues; elements 1:ILO-1 and i+1:N of W
*> contain those eigenvalues which have converged;
*> if JOBVS = 'V', VS contains the matrix which
*> reduces A to its partially converged Schur form.
*> = N+1: the eigenvalues could not be reordered because
*> some eigenvalues were too close to separate (the
*> problem is very ill-conditioned);
*> = N+2: after reordering, roundoff changed values of
*> some complex eigenvalues so that leading
*> eigenvalues in the Schur form no longer satisfy
*> SELECT = .TRUE.. This could also be caused by
*> underflow due to scaling.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gees
*
* =====================================================================
SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
$ LDVS, WORK, LWORK, RWORK, BWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBVS, SORT
INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELECT
EXTERNAL SELECT
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTST, WANTVS
INTEGER HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
$ ITAU, IWRK, MAXWRK, MINWRK
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZGEBAK, ZGEBAL,
$ ZGEHRD,
$ ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVS = LSAME( JOBVS, 'V' )
WANTST = LSAME( SORT, 'S' )
IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTST ) .AND.
$ ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.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
*
CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS,
$ WORK, -1, IEVAL )
HSWORK = INT( WORK( 1 ) )
*
IF( .NOT.WANTVS ) THEN
MAXWRK = MAX( MAXWRK, HSWORK )
ELSE
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1,
$ 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
MAXWRK = MAX( MAXWRK, HSWORK )
END IF
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( 'ZGEES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
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 )
*
* Permute the matrix to make it more nearly triangular
* (CWorkspace: none)
* (RWorkspace: need N)
*
IBAL = 1
CALL ZGEBAL( 'P', 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 = N + ITAU
CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVS ) THEN
*
* Copy Householder vectors to VS
*
CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS )
*
* Generate unitary matrix in VS
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ),
$ WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
END IF
*
SDIM = 0
*
* Perform QR iteration, accumulating Schur vectors in VS if desired
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
$ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
IF( IEVAL.GT.0 )
$ INFO = IEVAL
*
* Sort eigenvalues if desired
*
IF( WANTST .AND. INFO.EQ.0 ) THEN
IF( SCALEA )
$ CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
DO 10 I = 1, N
BWORK( I ) = SELECT( W( I ) )
10 CONTINUE
*
* Reorder eigenvalues and transform Schur vectors
* (CWorkspace: none)
* (RWorkspace: none)
*
CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W,
$ SDIM,
$ S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND )
END IF
*
IF( WANTVS ) THEN
*
* Undo balancing
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS,
$ LDVS,
$ IERR )
END IF
*
IF( SCALEA ) THEN
*
* Undo scaling for the Schur form of A
*
CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
CALL ZCOPY( N, A, LDA+1, W, 1 )
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of ZGEES
*
END
*> \brief <b> ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeev.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeev.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeev.f">
*> [TXT]</a>
*> \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 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.
*
*
* @precisions fortran z -> c
*
*> \ingroup geev
*
* =====================================================================
SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR,
$ LDVR,
$ WORK, LWORK, RWORK, INFO )
implicit none
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, LWORK_TREVC, 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 XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
$ ZHSEQR,
$ ZLACPY, ZLASCL, ZSCAL, ZTREVC3, 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, CONJG, AIMAG, 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 ZTREVC3( 'L', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
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 ZTREVC3( 'R', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
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 = INT( 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
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 .NE. 0 from ZHSEQR, then quit
*
IF( INFO.NE.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (CWorkspace: need 2*N, prefer N + 2*N*NB)
* (RWorkspace: need 2*N)
*
IRWORK = IBAL + N
CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR,
$ LDVR,
$ N, NOUT, WORK( IWRK ), LWORK-IWRK+1,
$ RWORK( IRWORK ), N, 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 +
$ AIMAG( VL( K, I ) )**2
10 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = CONJG( 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 +
$ AIMAG( VR( K, I ) )**2
30 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = CONJG( 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> ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEVX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeevx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeevx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeevx.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
* LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE,
* RCONDV, WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER BALANC, JOBVL, JOBVR, SENSE
* INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
* DOUBLE PRECISION ABNRM
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RCONDE( * ), RCONDV( * ), RWORK( * ),
* $ SCALE( * )
* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues and, optionally, the left and/or right eigenvectors.
*>
*> Optionally also, it computes a balancing transformation to improve
*> the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
*> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
*> (RCONDE), and reciprocal condition numbers for the right
*> eigenvectors (RCONDV).
*>
*> 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.
*>
*> Balancing a matrix means permuting the rows and columns to make it
*> more nearly upper triangular, and applying a diagonal similarity
*> transformation D * A * D**(-1), where D is a diagonal matrix, to
*> make its rows and columns closer in norm and the condition numbers
*> of its eigenvalues and eigenvectors smaller. The computed
*> reciprocal condition numbers correspond to the balanced matrix.
*> Permuting rows and columns will not change the condition numbers
*> (in exact arithmetic) but diagonal scaling will. For further
*> explanation of balancing, see section 4.10.2 of the LAPACK
*> Users' Guide.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] BALANC
*> \verbatim
*> BALANC is CHARACTER*1
*> Indicates how the input matrix should be diagonally scaled
*> and/or permuted to improve the conditioning of its
*> eigenvalues.
*> = 'N': Do not diagonally scale or permute;
*> = 'P': Perform permutations to make the matrix more nearly
*> upper triangular. Do not diagonally scale;
*> = 'S': Diagonally scale the matrix, ie. replace A by
*> D*A*D**(-1), where D is a diagonal matrix chosen
*> to make the rows and columns of A more equal in
*> norm. Do not permute;
*> = 'B': Both diagonally scale and permute A.
*>
*> Computed reciprocal condition numbers will be for the matrix
*> after balancing and/or permuting. Permuting does not change
*> condition numbers (in exact arithmetic), but balancing does.
*> \endverbatim
*>
*> \param[in] JOBVL
*> \verbatim
*> JOBVL is CHARACTER*1
*> = 'N': left eigenvectors of A are not computed;
*> = 'V': left eigenvectors of A are computed.
*> If SENSE = 'E' or 'B', JOBVL must = 'V'.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*> JOBVR is CHARACTER*1
*> = 'N': right eigenvectors of A are not computed;
*> = 'V': right eigenvectors of A are computed.
*> If SENSE = 'E' or 'B', JOBVR must = 'V'.
*> \endverbatim
*>
*> \param[in] SENSE
*> \verbatim
*> SENSE is CHARACTER*1
*> Determines which reciprocal condition numbers are computed.
*> = 'N': None are computed;
*> = 'E': Computed for eigenvalues only;
*> = 'V': Computed for right eigenvectors only;
*> = 'B': Computed for eigenvalues and right eigenvectors.
*>
*> If SENSE = 'E' or 'B', both left and right eigenvectors
*> must also be computed (JOBVL = 'V' and JOBVR = 'V').
*> \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. If JOBVL = 'V' or
*> JOBVR = 'V', A contains the Schur form of the balanced
*> version of the matrix A.
*> \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] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*> IHI is INTEGER
*> ILO and IHI are integer values determined when A was
*> balanced. The balanced A(i,j) = 0 if I > J and
*> J = 1,...,ILO-1 or I = IHI+1,...,N.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and scaling factors applied
*> when balancing 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] ABNRM
*> \verbatim
*> ABNRM is DOUBLE PRECISION
*> The one-norm of the balanced matrix (the maximum
*> of the sum of absolute values of elements of any column).
*> \endverbatim
*>
*> \param[out] RCONDE
*> \verbatim
*> RCONDE is DOUBLE PRECISION array, dimension (N)
*> RCONDE(j) is the reciprocal condition number of the j-th
*> eigenvalue.
*> \endverbatim
*>
*> \param[out] RCONDV
*> \verbatim
*> RCONDV is DOUBLE PRECISION array, dimension (N)
*> RCONDV(j) is the reciprocal condition number of the j-th
*> right eigenvector.
*> \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 SENSE = 'N' or 'E',
*> LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
*> LWORK >= N*N+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 or condition numbers
*> have been computed; elements 1:ILO-1 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.
*
*
* @precisions fortran z -> c
*
*> \ingroup geevx
*
* =====================================================================
SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W,
$ VL,
$ LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE,
$ RCONDV, WORK, LWORK, RWORK, INFO )
implicit none
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER BALANC, JOBVL, JOBVR, SENSE
INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
DOUBLE PRECISION ABNRM
* ..
* .. Array Arguments ..
DOUBLE PRECISION RCONDE( * ), RCONDV( * ), RWORK( * ),
$ SCALE( * )
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, WNTSNB, WNTSNE,
$ WNTSNN, WNTSNV
CHARACTER JOB, SIDE
INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K,
$ LWORK_TREVC, 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 DLASCL, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL,
$ ZGEHRD,
$ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZTRSNA,
$ 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, CONJG, AIMAG, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
WNTSNN = LSAME( SENSE, 'N' )
WNTSNE = LSAME( SENSE, 'E' )
WNTSNV = LSAME( SENSE, 'V' )
WNTSNB = LSAME( SENSE, 'B' )
IF( .NOT.( LSAME( BALANC, 'N' ) .OR.
$ LSAME( BALANC, 'S' ) .OR.
$ LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVL ) .AND.
$ ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTVR ) .AND.
$ ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -3
ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
$ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
$ WANTVR ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -10
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -12
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 )
*
IF( WANTVL ) THEN
CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, LWORK_TREVC )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
$ WORK, -1, INFO )
ELSE IF( WANTVR ) THEN
CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, LWORK_TREVC )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
$ WORK, -1, INFO )
ELSE
IF( WNTSNN ) THEN
CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR,
$ LDVR,
$ WORK, -1, INFO )
ELSE
CALL ZHSEQR( 'S', 'N', N, 1, N, A, LDA, W, VR,
$ LDVR,
$ WORK, -1, INFO )
END IF
END IF
HSWORK = INT( WORK(1) )
*
IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
MINWRK = 2*N
IF( .NOT.( WNTSNN .OR. WNTSNE ) )
$ MINWRK = MAX( MINWRK, N*N + 2*N )
MAXWRK = MAX( MAXWRK, HSWORK )
IF( .NOT.( WNTSNN .OR. WNTSNE ) )
$ MAXWRK = MAX( MAXWRK, N*N + 2*N )
ELSE
MINWRK = 2*N
IF( .NOT.( WNTSNN .OR. WNTSNE ) )
$ MINWRK = MAX( MINWRK, N*N + 2*N )
MAXWRK = MAX( MAXWRK, HSWORK )
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1,
$ 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
IF( .NOT.( WNTSNN .OR. WNTSNE ) )
$ MAXWRK = MAX( MAXWRK, N*N + 2*N )
MAXWRK = MAX( MAXWRK, 2*N )
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEEVX', -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
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ICOND = 0
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 and compute ABNRM
*
CALL ZGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
ABNRM = ZLANGE( '1', N, N, A, LDA, DUM )
IF( SCALEA ) THEN
DUM( 1 ) = ABNRM
CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
ABNRM = DUM( 1 )
END IF
*
* 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
* If condition numbers desired, compute Schur form
*
IF( WNTSNN ) THEN
JOB = 'E'
ELSE
JOB = 'S'
END IF
*
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO .NE. 0 from ZHSEQR, then quit
*
IF( INFO.NE.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (CWorkspace: need 2*N, prefer N + 2*N*NB)
* (RWorkspace: need N)
*
CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR,
$ LDVR,
$ N, NOUT, WORK( IWRK ), LWORK-IWRK+1,
$ RWORK, N, IERR )
END IF
*
* Compute condition numbers if desired
* (CWorkspace: need N*N+2*N unless SENSE = 'E')
* (RWorkspace: need 2*N unless SENSE = 'E')
*
IF( .NOT.WNTSNN ) THEN
CALL ZTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR,
$ LDVR,
$ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, RWORK,
$ ICOND )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
*
CALL ZGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, 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( K ) = DBLE( VL( K, I ) )**2 +
$ AIMAG( VL( K, I ) )**2
10 CONTINUE
K = IDAMAX( N, RWORK, 1 )
TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( K ) )
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
*
CALL ZGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, 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( K ) = DBLE( VR( K, I ) )**2 +
$ AIMAG( VR( K, I ) )**2
30 CONTINUE
K = IDAMAX( N, RWORK, 1 )
TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( K ) )
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.EQ.0 ) THEN
IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
$ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
$ IERR )
ELSE
CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N,
$ IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of ZGEEVX
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgehd2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgehd2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgehd2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup gehd2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF1F, 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)
*
CALL ZLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
CALL ZLARF1F( '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 ZLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1,
$ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgehrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgehrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgehrd.f">
*> [TXT]</a>
*> \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 (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,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] 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.
*
*> \ingroup gehrd
*
*> \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 ZGEHRD
*> subroutine incorporating improvements proposed by Quintana-Orti and
*> Van de Geijn (2006). (See ZLAHR2.)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
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, IWT, J, LDWORK, LWKOPT, NB,
$ NBMIN, NH, NX
COMPLEX*16 EI
* ..
* .. 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
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
*
NH = IHI - ILO + 1
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
IF( NH.LE.1 ) THEN
LWKOPT = 1
ELSE
NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI,
$ -1 ) )
LWKOPT = N*NB + TSIZE
END IF
WORK( 1 ) = LWKOPT
ENDIF
*
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
*
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
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
*
IF( LWORK.LT.LWKOPT ) 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 + TSIZE) ) THEN
NB = (LWORK-TSIZE) / 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
*
IWT = 1 + N*NB
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 ),
$ WORK( IWT ), 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,
$ WORK( IWT ), 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 ) = LWKOPT
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelq2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelq2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelq2.f">
*> [TXT]</a>
*> \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 0 ) * Q
*>
*> where:
*>
*> Q is a n-by-n orthogonal matrix;
*> L is a lower-triangular m-by-m matrix;
*> 0 is a m-by-(n-m) zero matrix, if m < n.
*>
*> \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.
*
*> \ingroup gelq2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF1F, 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 )
CALL ZLARFG( N-I+1, A( I, I ), 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
*
CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAU( I ),
$ A( I+1, I ), LDA, WORK )
END IF
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelqf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelqf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelqf.f">
*> [TXT]</a>
*> \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 0 ) * Q
*>
*> where:
*>
*> Q is a N-by-N orthogonal matrix;
*> L is a lower-triangular M-by-M matrix;
*> 0 is a M-by-(N-M) zero matrix, if M < N.
*>
*> \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 >= 1, if MIN(M,N) = 0, and LWORK >= M, otherwise.
*> 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.
*
*> \ingroup gelqf
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
K = MIN( M, N )
NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
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( .NOT.LQUERY ) THEN
IF( LWORK.LE.0 .OR. ( N.GT.0 .AND. LWORK.LT.MAX( 1, M ) ) )
$ INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
LWKOPT = M*NB
END IF
WORK( 1 ) = LWKOPT
RETURN
END IF
*
* Quick return if possible
*
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> ZGELS solves overdetermined or underdetermined systems for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgels.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgels.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgels.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELS solves overdetermined or underdetermined complex linear systems
*> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
*> or LQ factorization of A.
*>
*> It is assumed that A has full rank, and only a rudimentary protection
*> against rank-deficient matrices is provided. This subroutine only detects
*> exact rank-deficiency, where a diagonal element of the triangular factor
*> of A is exactly zero.
*>
*> It is conceivable for one (or more) of the diagonal elements of the triangular
*> factor of A to be subnormally tiny numbers without this subroutine signalling
*> an error. The solutions computed for such almost-rank-deficient matrices may
*> be less accurate due to a loss of numerical precision.
*>
*> The following options are provided:
*>
*> 1. If TRANS = 'N' and m >= n: find the least squares solution of
*> an overdetermined system, i.e., solve the least squares problem
*> minimize || B - A*X ||.
*>
*> 2. If TRANS = 'N' and m < n: find the minimum norm solution of
*> an underdetermined system A * X = B.
*>
*> 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
*> an underdetermined system A**H * X = B.
*>
*> 4. If TRANS = 'C' and m < n: find the least squares solution of
*> an overdetermined system, i.e., solve the least squares problem
*> minimize || B - A**H * X ||.
*>
*> 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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': the linear system involves A;
*> = 'C': the linear system involves A**H.
*> \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] 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,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> if M >= N, A is overwritten by details of its QR
*> factorization as returned by ZGEQRF;
*> if M < N, A is overwritten by details of its LQ
*> factorization as returned by ZGELQF.
*> \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 matrix B of right hand side vectors, stored
*> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
*> if TRANS = 'C'.
*> On exit, if INFO = 0, B is overwritten by the solution
*> vectors, stored columnwise:
*> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
*> squares solution vectors; the residual sum of squares for the
*> solution in each column is given by the sum of squares of the
*> modulus of elements N+1 to M in that column;
*> if TRANS = 'N' and m < n, rows 1 to N of B contain the
*> minimum norm solution vectors;
*> if TRANS = 'C' and m >= n, rows 1 to M of B contain the
*> minimum norm solution vectors;
*> if TRANS = 'C' and m < n, rows 1 to M of B contain the
*> least squares solution vectors; the residual sum of squares
*> for the solution in each column is given by the sum of
*> squares of the modulus of elements M+1 to N 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] 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, MN + max( MN, NRHS ) ).
*> For optimal performance,
*> LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
*> where MN = min(M,N) and NB is the optimum block size.
*>
*> 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
*> > 0: if INFO = i, the i-th diagonal element of the
*> triangular factor of A is exactly zero, so that A does not have
*> full rank; the least squares solution could not be
*> computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gels
*
* =====================================================================
SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK,
$ LWORK,
$ INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, TPSD
INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGELQF, ZGEQRF, ZLASCL,
$ ZLASET,
$ ZTRTRS, ZUNMLQ, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
INFO = 0
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
$ LSAME( TRANS, 'C' ) ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
$ THEN
INFO = -10
END IF
*
* Figure out optimal block size
*
IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
*
TPSD = .TRUE.
IF( LSAME( TRANS, 'N' ) )
$ TPSD = .FALSE.
*
IF( M.GE.N ) THEN
NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LN', M, NRHS, N,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N,
$ -1 ) )
END IF
ELSE
NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
IF( TPSD ) THEN
NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M,
$ -1 ) )
ELSE
NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LN', N, NRHS, M,
$ -1 ) )
END IF
END IF
*
WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
WORK( 1 ) = DBLE( WSIZE )
*
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELS ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( MIN( M, N, NRHS ).EQ.0 ) THEN
CALL ZLASET( 'Full', MAX( M, N ), NRHS, CZERO, CZERO, B,
$ LDB )
RETURN
END IF
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
BIGNUM = ONE / SMLNUM
*
* Scale A, B if max element 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 )
GO TO 50
END IF
*
BROW = M
IF( TPSD )
$ BROW = N
BNRM = ZLANGE( 'M', BROW, 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, BROW, 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, BROW, NRHS, B, LDB,
$ INFO )
IBSCL = 2
END IF
*
IF( M.GE.N ) THEN
*
* compute QR factorization of A
*
CALL ZGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN,
$ INFO )
*
* workspace at least N, optimally N*NB
*
IF( .NOT.TPSD ) THEN
*
* Least-Squares Problem min || A * X - B ||
*
* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS)
*
CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, N,
$ A,
$ LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = N
*
ELSE
*
* Underdetermined system of equations A**T * X = B
*
* B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS)
*
CALL ZTRTRS( 'Upper', 'Conjugate transpose','Non-unit',
$ N, NRHS, A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(N+1:M,1:NRHS) = ZERO
*
DO 20 J = 1, NRHS
DO 10 I = N + 1, M
B( I, J ) = CZERO
10 CONTINUE
20 CONTINUE
*
* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
CALL ZUNMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = M
*
END IF
*
ELSE
*
* Compute LQ factorization of A
*
CALL ZGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ),
$ LWORK-MN,
$ INFO )
*
* workspace at least M, optimally M*NB.
*
IF( .NOT.TPSD ) THEN
*
* underdetermined system of equations A * X = B
*
* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
CALL ZTRTRS( 'Lower', 'No transpose', 'Non-unit', M,
$ NRHS,
$ A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
* B(M+1:N,1:NRHS) = 0
*
DO 40 J = 1, NRHS
DO 30 I = M + 1, N
B( I, J ) = CZERO
30 CONTINUE
40 CONTINUE
*
* B(1:N,1:NRHS) := Q(1:N,:)**H * B(1:M,1:NRHS)
*
CALL ZUNMLQ( 'Left', 'Conjugate transpose', N, NRHS, M,
$ A,
$ LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
SCLLEN = N
*
ELSE
*
* overdetermined system min || A**H * X - B ||
*
* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
CALL ZUNMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
$ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
$ INFO )
*
* workspace at least NRHS, optimally NRHS*NB
*
* B(1:M,1:NRHS) := inv(L**H) * B(1:M,1:NRHS)
*
CALL ZTRTRS( 'Lower', 'Conjugate transpose', 'Non-unit',
$ M, NRHS, A, LDA, B, LDB, INFO )
*
IF( INFO.GT.0 ) THEN
RETURN
END IF
*
SCLLEN = M
*
END IF
*
END IF
*
* Undo scaling
*
IF( IASCL.EQ.1 ) THEN
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IASCL.EQ.2 ) THEN
CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
IF( IBSCL.EQ.1 ) THEN
CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
ELSE IF( IBSCL.EQ.2 ) THEN
CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
$ INFO )
END IF
*
50 CONTINUE
WORK( 1 ) = DBLE( WSIZE )
*
RETURN
*
* End of ZGELS
*
END
*> \brief <b> ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELSD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgelsd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgelsd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgelsd.f">
*> [TXT]</a>
*> \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 transformations, 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 transformations 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.
*>
*> \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,out] 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.
*
*> \ingroup gelsd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*
* 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 ZGEQP3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQP3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqp3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqp3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqp3.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup geqp3
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ) = DCMPLX( 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
*
* 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 ) = DCMPLX( LWKOPT )
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqr2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqr2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqr2.f">
*> [TXT]</a>
*> \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 ),
*> ( 0 )
*>
*> where:
*>
*> Q is a m-by-m orthogonal matrix;
*> R is an upper-triangular n-by-n matrix;
*> 0 is a (m-n)-by-n zero matrix, if m > n.
*>
*> \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.
*
*> \ingroup geqr2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF1F, 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
*
CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
$ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgeqrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgeqrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgeqrf.f">
*> [TXT]</a>
*> \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 ),
*> ( 0 )
*>
*> where:
*>
*> Q is a M-by-M orthogonal matrix;
*> R is an upper-triangular N-by-N matrix;
*> 0 is a (M-N)-by-N zero matrix, if M > N.
*>
*> \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 >= 1, if MIN(M,N) = 0, and LWORK >= N, otherwise.
*> 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.
*
*> \ingroup geqrf
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*
K = MIN( M, N )
INFO = 0
NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
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( .NOT.LQUERY ) THEN
IF( LWORK.LE.0 .OR. ( M.GT.0 .AND. LWORK.LT.MAX( 1, N ) ) )
$ INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
IF( K.EQ.0 ) THEN
LWKOPT = 1
ELSE
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
RETURN
END IF
*
* Quick return if possible
*
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 \b ZGERFS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGERFS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgerfs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgerfs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgerfs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
* X, LDX, FERR, BERR, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGERFS improves the computed solution to a system of linear
*> equations and provides error bounds and backward error estimates for
*> the solution.
*> \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 matrices B and X. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The original N-by-N matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] AF
*> \verbatim
*> AF is COMPLEX*16 array, dimension (LDAF,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by ZGETRF.
*> \endverbatim
*>
*> \param[in] LDAF
*> \verbatim
*> LDAF is INTEGER
*> The leading dimension of the array AF. LDAF >= 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] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> On entry, the solution matrix X, as computed by ZGETRS.
*> On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gerfs
*
* =====================================================================
SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
$ LDB,
$ X, LDX, FERR, BERR, WORK, RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANSN, TRANST
INTEGER COUNT, I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGETRS,
$ ZLACN2
* ..
* .. 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
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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGERFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANSN = 'N'
TRANST = 'C'
ELSE
TRANSN = 'C'
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
CALL ZGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
$ WORK,
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
RWORK( I ) = CABS1( B( I, J ) )
30 CONTINUE
*
* Compute abs(op(A))*abs(X) + abs(B).
*
IF( NOTRAN ) THEN
DO 50 K = 1, N
XK = CABS1( X( K, J ) )
DO 40 I = 1, N
RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
40 CONTINUE
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
DO 60 I = 1, N
S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
60 CONTINUE
RWORK( K ) = RWORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
ELSE
S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
$ ( RWORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL ZGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use ZLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
ELSE
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
$ SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**H).
*
CALL ZGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK, N,
$ INFO )
DO 110 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
110 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 120 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
120 CONTINUE
CALL ZGETRS( TRANSN, N, 1, AF, LDAF, IPIV, WORK, N,
$ INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of ZGERFS
*
END
*> \brief \b ZGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESC2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesc2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesc2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesc2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* .. Scalar Arguments ..
* INTEGER LDA, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* COMPLEX*16 A( LDA, * ), RHS( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESC2 solves a system of linear equations
*>
*> A * X = scale* RHS
*>
*> with a general N-by-N matrix A using the LU factorization with
*> complete pivoting computed by ZGETC2.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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)
*> On entry, the LU part of the factorization of the n-by-n
*> matrix A computed by ZGETC2: A = P * L * U * Q
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] RHS
*> \verbatim
*> RHS is COMPLEX*16 array, dimension N.
*> On entry, the right hand side vector b.
*> On exit, the solution vector X.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On exit, SCALE contains the scale factor. SCALE is chosen
*> 0 <= SCALE <= 1 to prevent overflow in the solution.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gesc2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
COMPLEX*16 A( LDA, * ), RHS( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION BIGNUM, EPS, SMLNUM
COMPLEX*16 TEMP
* ..
* .. External Subroutines ..
EXTERNAL ZLASWP, ZSCAL
* ..
* .. External Functions ..
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IZAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX
* ..
* .. Executable Statements ..
*
* Set constant to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
* Apply permutations IPIV to RHS
*
CALL ZLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
*
* Solve for L part
*
DO 20 I = 1, N - 1
DO 10 J = I + 1, N
RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
10 CONTINUE
20 CONTINUE
*
* Solve for U part
*
SCALE = ONE
*
* Check for scaling
*
I = IZAMAX( N, RHS, 1 )
IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
TEMP = DCMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) )
CALL ZSCAL( N, TEMP, RHS( 1 ), 1 )
SCALE = SCALE*DBLE( TEMP )
END IF
DO 40 I = N, 1, -1
TEMP = DCMPLX( ONE, ZERO ) / A( I, I )
RHS( I ) = RHS( I )*TEMP
DO 30 J = I + 1, N
RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
30 CONTINUE
40 CONTINUE
*
* Apply permutations JPIV to the solution (RHS)
*
CALL ZLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
RETURN
*
* End of ZGESC2
*
END
*> \brief \b ZGESDD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESDD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesdd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesdd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesdd.f">
*> [TXT]</a>
*> \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.
*>
*> \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 LWORK = -1, a workspace query is assumed. The optimal
*> size for the WORK array is calculated and stored in WORK(1),
*> and no other work except argument checking is performed.
*>
*> Let mx = max(M,N) and mn = min(M,N).
*> If JOBZ = 'N', LWORK >= 2*mn + mx.
*> If JOBZ = 'O', LWORK >= 2*mn*mn + 2*mn + mx.
*> If JOBZ = 'S', LWORK >= mn*mn + 3*mn.
*> If JOBZ = 'A', LWORK >= mn*mn + 2*mn + mx.
*> These are not tight minimums in all cases; see comments inside code.
*> For good performance, LWORK should generally be larger;
*> a query is recommended.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> Let mx = max(M,N) and mn = min(M,N).
*> If JOBZ = 'N', LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn);
*> else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn;
*> else LRWORK >= max( 5*mn*mn + 5*mn,
*> 2*mx*mn + 2*mn*mn + mn ).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (8*min(M,N))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> = -4: if A had a NAN entry.
*> > 0: The updating process of DBDSDC did not converge.
*> = 0: successful exit.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gesdd
*
*> \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 )
implicit none
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ..
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 LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
INTEGER BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT,
$ ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
$ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
$ MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL
INTEGER LWORK_ZGEBRD_MN, LWORK_ZGEBRD_MM,
$ LWORK_ZGEBRD_NN, LWORK_ZGELQF_MN,
$ LWORK_ZGEQRF_MN,
$ LWORK_ZUNGBR_P_MN, LWORK_ZUNGBR_P_NN,
$ LWORK_ZUNGBR_Q_MN, LWORK_ZUNGBR_Q_MM,
$ LWORK_ZUNGLQ_MN, LWORK_ZUNGLQ_NN,
$ LWORK_ZUNGQR_MM, LWORK_ZUNGQR_MN,
$ LWORK_ZUNMBR_PRC_MM, LWORK_ZUNMBR_QLN_MM,
$ LWORK_ZUNMBR_PRC_MN, LWORK_ZUNMBR_QLN_MN,
$ LWORK_ZUNMBR_PRC_NN, LWORK_ZUNMBR_QLN_NN
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DUM( 1 )
COMPLEX*16 CDUM( 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, DISNAN
DOUBLE PRECISION DLAMCH, ZLANGE, DROUNDUP_LWORK
EXTERNAL LSAME, DLAMCH, ZLANGE, DISNAN,
$ DROUNDUP_LWORK
* ..
* .. 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' )
LQUERY = ( LWORK.EQ.-1 )
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 allocated at that point in the code,
* as well as the preferred amount for good performance.
* CWorkspace refers to complex workspace, and RWorkspace to
* real workspace. NB refers to the optimal block size for the
* immediately following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* There is no complex work space needed for bidiagonal SVD
* The real work space needed for bidiagonal SVD (dbdsdc) is
* BDSPAC = 3*N*N + 4*N for singular values and vectors;
* BDSPAC = 4*N for singular values only;
* not including e, RU, and RVT matrices.
*
* Compute space preferred for each routine
CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD_MN = INT( CDUM(1) )
*
CALL ZGEBRD( N, N, CDUM(1), N, DUM(1), DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD_NN = INT( CDUM(1) )
*
CALL ZGEQRF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZGEQRF_MN = INT( CDUM(1) )
*
CALL ZUNGBR( 'P', N, N, N, CDUM(1), N, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_P_NN = INT( CDUM(1) )
*
CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_Q_MM = INT( CDUM(1) )
*
CALL ZUNGBR( 'Q', M, N, N, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_Q_MN = INT( CDUM(1) )
*
CALL ZUNGQR( M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGQR_MM = INT( CDUM(1) )
*
CALL ZUNGQR( M, N, N, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGQR_MN = INT( CDUM(1) )
*
CALL ZUNMBR( 'P', 'R', 'C', N, N, N, CDUM(1), N, CDUM(1),
$ CDUM(1), N, CDUM(1), -1, IERR )
LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) )
*
CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, CDUM(1), M, CDUM(1),
$ CDUM(1), M, CDUM(1), -1, IERR )
LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) )
*
CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, CDUM(1), M, CDUM(1),
$ CDUM(1), M, CDUM(1), -1, IERR )
LWORK_ZUNMBR_QLN_MN = INT( CDUM(1) )
*
CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, CDUM(1), N, CDUM(1),
$ CDUM(1), N, CDUM(1), -1, IERR )
LWORK_ZUNMBR_QLN_NN = INT( CDUM(1) )
*
IF( M.GE.MNTHR1 ) THEN
IF( WNTQN ) THEN
*
* Path 1 (M >> N, JOBZ='N')
*
MAXWRK = N + LWORK_ZGEQRF_MN
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZGEBRD_NN )
MINWRK = 3*N
ELSE IF( WNTQO ) THEN
*
* Path 2 (M >> N, JOBZ='O')
*
WRKBL = N + LWORK_ZGEQRF_MN
WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
MAXWRK = M*N + N*N + WRKBL
MINWRK = 2*N*N + 3*N
ELSE IF( WNTQS ) THEN
*
* Path 3 (M >> N, JOBZ='S')
*
WRKBL = N + LWORK_ZGEQRF_MN
WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
MAXWRK = N*N + WRKBL
MINWRK = N*N + 3*N
ELSE IF( WNTQA ) THEN
*
* Path 4 (M >> N, JOBZ='A')
*
WRKBL = N + LWORK_ZGEQRF_MN
WRKBL = MAX( WRKBL, N + LWORK_ZUNGQR_MM )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZGEBRD_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_QLN_NN )
WRKBL = MAX( WRKBL, 2*N + LWORK_ZUNMBR_PRC_NN )
MAXWRK = N*N + WRKBL
MINWRK = N*N + MAX( 3*N, N + M )
END IF
ELSE IF( M.GE.MNTHR2 ) THEN
*
* Path 5 (M >> N, but not as much as MNTHR1)
*
MAXWRK = 2*N + LWORK_ZGEBRD_MN
MINWRK = 2*N + M
IF( WNTQO ) THEN
* Path 5o (M >> N, JOBZ='O')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN )
MAXWRK = MAXWRK + M*N
MINWRK = MINWRK + N*N
ELSE IF( WNTQS ) THEN
* Path 5s (M >> N, JOBZ='S')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MN )
ELSE IF( WNTQA ) THEN
* Path 5a (M >> N, JOBZ='A')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_P_NN )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNGBR_Q_MM )
END IF
ELSE
*
* Path 6 (M >= N, but not much larger)
*
MAXWRK = 2*N + LWORK_ZGEBRD_MN
MINWRK = 2*N + M
IF( WNTQO ) THEN
* Path 6o (M >= N, JOBZ='O')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN )
MAXWRK = MAXWRK + M*N
MINWRK = MINWRK + N*N
ELSE IF( WNTQS ) THEN
* Path 6s (M >= N, JOBZ='S')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MN )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
ELSE IF( WNTQA ) THEN
* Path 6a (M >= N, JOBZ='A')
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_QLN_MM )
MAXWRK = MAX( MAXWRK, 2*N + LWORK_ZUNMBR_PRC_NN )
END IF
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* There is no complex work space needed for bidiagonal SVD
* The real work space needed for bidiagonal SVD (dbdsdc) is
* BDSPAC = 3*M*M + 4*M for singular values and vectors;
* BDSPAC = 4*M for singular values only;
* not including e, RU, and RVT matrices.
*
* Compute space preferred for each routine
CALL ZGEBRD( M, N, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD_MN = INT( CDUM(1) )
*
CALL ZGEBRD( M, M, CDUM(1), M, DUM(1), DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD_MM = INT( CDUM(1) )
*
CALL ZGELQF( M, N, CDUM(1), M, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZGELQF_MN = INT( CDUM(1) )
*
CALL ZUNGBR( 'P', M, N, M, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_P_MN = INT( CDUM(1) )
*
CALL ZUNGBR( 'P', N, N, M, CDUM(1), N, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_P_NN = INT( CDUM(1) )
*
CALL ZUNGBR( 'Q', M, M, N, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGBR_Q_MM = INT( CDUM(1) )
*
CALL ZUNGLQ( M, N, M, CDUM(1), M, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGLQ_MN = INT( CDUM(1) )
*
CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1),
$ -1, IERR )
LWORK_ZUNGLQ_NN = INT( CDUM(1) )
*
CALL ZUNMBR( 'P', 'R', 'C', M, M, M, CDUM(1), M, CDUM(1),
$ CDUM(1), M, CDUM(1), -1, IERR )
LWORK_ZUNMBR_PRC_MM = INT( CDUM(1) )
*
CALL ZUNMBR( 'P', 'R', 'C', M, N, M, CDUM(1), M, CDUM(1),
$ CDUM(1), M, CDUM(1), -1, IERR )
LWORK_ZUNMBR_PRC_MN = INT( CDUM(1) )
*
CALL ZUNMBR( 'P', 'R', 'C', N, N, M, CDUM(1), N, CDUM(1),
$ CDUM(1), N, CDUM(1), -1, IERR )
LWORK_ZUNMBR_PRC_NN = INT( CDUM(1) )
*
CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, CDUM(1), M, CDUM(1),
$ CDUM(1), M, CDUM(1), -1, IERR )
LWORK_ZUNMBR_QLN_MM = INT( CDUM(1) )
*
IF( N.GE.MNTHR1 ) THEN
IF( WNTQN ) THEN
*
* Path 1t (N >> M, JOBZ='N')
*
MAXWRK = M + LWORK_ZGELQF_MN
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZGEBRD_MM )
MINWRK = 3*M
ELSE IF( WNTQO ) THEN
*
* Path 2t (N >> M, JOBZ='O')
*
WRKBL = M + LWORK_ZGELQF_MN
WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_MN )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
MAXWRK = M*N + M*M + WRKBL
MINWRK = 2*M*M + 3*M
ELSE IF( WNTQS ) THEN
*
* Path 3t (N >> M, JOBZ='S')
*
WRKBL = M + LWORK_ZGELQF_MN
WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_MN )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
MAXWRK = M*M + WRKBL
MINWRK = M*M + 3*M
ELSE IF( WNTQA ) THEN
*
* Path 4t (N >> M, JOBZ='A')
*
WRKBL = M + LWORK_ZGELQF_MN
WRKBL = MAX( WRKBL, M + LWORK_ZUNGLQ_NN )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZGEBRD_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_QLN_MM )
WRKBL = MAX( WRKBL, 2*M + LWORK_ZUNMBR_PRC_MM )
MAXWRK = M*M + WRKBL
MINWRK = M*M + MAX( 3*M, M + N )
END IF
ELSE IF( N.GE.MNTHR2 ) THEN
*
* Path 5t (N >> M, but not as much as MNTHR1)
*
MAXWRK = 2*M + LWORK_ZGEBRD_MN
MINWRK = 2*M + N
IF( WNTQO ) THEN
* Path 5to (N >> M, JOBZ='O')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN )
MAXWRK = MAXWRK + M*N
MINWRK = MINWRK + M*M
ELSE IF( WNTQS ) THEN
* Path 5ts (N >> M, JOBZ='S')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_MN )
ELSE IF( WNTQA ) THEN
* Path 5ta (N >> M, JOBZ='A')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_Q_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNGBR_P_NN )
END IF
ELSE
*
* Path 6t (N > M, but not much larger)
*
MAXWRK = 2*M + LWORK_ZGEBRD_MN
MINWRK = 2*M + N
IF( WNTQO ) THEN
* Path 6to (N > M, JOBZ='O')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN )
MAXWRK = MAXWRK + M*N
MINWRK = MINWRK + M*M
ELSE IF( WNTQS ) THEN
* Path 6ts (N > M, JOBZ='S')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_MN )
ELSE IF( WNTQA ) THEN
* Path 6ta (N > M, JOBZ='A')
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_QLN_MM )
MAXWRK = MAX( MAXWRK, 2*M + LWORK_ZUNMBR_PRC_NN )
END IF
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
END IF
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = DROUNDUP_LWORK( MAXWRK )
IF( LWORK.LT.MINWRK .AND. .NOT. LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESDD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
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 )
IF( DISNAN( ANRM ) ) THEN
INFO = -4
RETURN
END IF
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 >> N, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + N
*
* Compute A=Q*R
* CWorkspace: need N [tau] + N [work]
* CWorkspace: prefer N [tau] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + 2*N*NB [work]
* RWorkspace: need N [e]
*
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: need 0
* RWorkspace: need N [e] + BDSPAC
*
CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM,1,DUM,1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
*
ELSE IF( WNTQO ) THEN
*
* Path 2 (M >> 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 [U] + N*N [R] + N [tau] + N [work]
* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 N*N [U] + N*N [R] + N [tau] + N [work]
* CWorkspace: prefer N*N [U] + N*N [R] + N [tau] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [U] + N*N [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
* RWorkspace: need N [e]
*
CALL 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 N [e] + N*N [RU] + N*N [RVT] + 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 N*N [U] + N*N [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [U] + N*N [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + N*N [R] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 N*N [U] + N*N [R]
* CWorkspace: prefer N*N [U] + M*N [R]
* RWorkspace: need 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 >> N, JOBZ='S')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IR = 1
*
* WORK(IR) is N by N
*
LDWRKR = N
ITAU = IR + LDWRKR*N
NWORK = ITAU + N
*
* Compute A=Q*R
* CWorkspace: need N*N [R] + N [tau] + N [work]
* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 N*N [R] + N [tau] + N [work]
* CWorkspace: prefer N*N [R] + N [tau] + N*NB [work]
* RWorkspace: need 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 [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + 2*N*NB [work]
* RWorkspace: need N [e]
*
CALL 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 N [e] + N*N [RU] + N*N [RVT] + 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 [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 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 [R] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [R] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 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 [R]
* RWorkspace: need 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 >> N, JOBZ='A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IU = 1
*
* WORK(IU) is N by N
*
LDWRKU = N
ITAU = IU + LDWRKU*N
NWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* CWorkspace: need N*N [U] + N [tau] + N [work]
* CWorkspace: prefer N*N [U] + N [tau] + N*NB [work]
* RWorkspace: need 0
*
CALL 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*N [U] + N [tau] + M [work]
* CWorkspace: prefer N*N [U] + N [tau] + M*NB [work]
* RWorkspace: need 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 N*N [U] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + 2*N*NB [work]
* RWorkspace: need N [e]
*
CALL 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 N [e] + N*N [RU] + N*N [RVT] + 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 [U] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 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 N*N [U] + 2*N [tauq, taup] + N [work]
* CWorkspace: prefer N*N [U] + 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [U]
* RWorkspace: need 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 >> 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
* RWorkspace: need N [e]
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Path 5n (M >> N, JOBZ='N')
* Compute singular values only
* CWorkspace: need 0
* RWorkspace: need N [e] + BDSPAC
*
CALL 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
*
* Path 5o (M >> N, JOBZ='O')
* Copy A to VT, generate P**H
* CWorkspace: need 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 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 N [e] + N*N [RU] + N*N [RVT] + 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 2*N [tauq, taup] + N*N [U]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
*
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 2*N [tauq, taup] + N*N [U]
* CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork]
* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
*
NRWORK = IRVT
DO 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
*
* Path 5s (M >> N, JOBZ='S')
* Copy A to VT, generate P**H
* CWorkspace: need 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 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 N [e] + N*N [RU] + N*N [RVT] + 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 N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
*
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 [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
*
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
*
* Path 5a (M >> N, JOBZ='A')
* Copy A to VT, generate P**H
* CWorkspace: need 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
* RWorkspace: need 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 N [e] + N*N [RU] + N*N [RVT] + 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 N [e] + N*N [RU] + N*N [RVT] + 2*N*N [rwork]
*
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 [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
*
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 >= 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*N [tauq, taup] + (M+N)*NB [work]
* RWorkspace: need N [e]
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Path 6n (M >= N, JOBZ='N')
* Compute singular values only
* CWorkspace: need 0
* RWorkspace: need N [e] + BDSPAC
*
CALL 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
*
* Path 6o (M >= N, JOBZ='O')
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(IRVT)
* CWorkspace: need 0
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC
*
CALL 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 [tauq, taup] + N*N [U] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT]
*
CALL 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
*
* Path 6o-fast
* Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
* Overwrite WORK(IU) by left singular vectors of A, copying
* to A
* CWorkspace: need 2*N [tauq, taup] + M*N [U] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + M*N [U] + N*NB [work]
* RWorkspace: need N [e] + N*N [RU]
*
CALL 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
*
* Path 6o-slow
* Generate Q in A
* CWorkspace: need 2*N [tauq, taup] + N*N [U] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*N [U] + N*NB [work]
* RWorkspace: need 0
*
CALL 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 2*N [tauq, taup] + N*N [U]
* CWorkspace: prefer 2*N [tauq, taup] + M*N [U]
* RWorkspace: need N [e] + N*N [RU] + 2*N*N [rwork]
* RWorkspace: prefer N [e] + N*N [RU] + 2*M*N [rwork] < N + 5*N*N since M < 2*N here
*
NRWORK = IRVT
DO 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
*
* Path 6s (M >= N, JOBZ='S')
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(IRVT)
* CWorkspace: need 0
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC
*
IRU = NRWORK
IRVT = IRU + N*N
NRWORK = IRVT + N*N
CALL 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 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT]
*
CALL 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 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT]
*
CALL 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
*
* Path 6a (M >= N, JOBZ='A')
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(IRVT)
* CWorkspace: need 0
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT] + BDSPAC
*
IRU = NRWORK
IRVT = IRU + N*N
NRWORK = IRVT + N*N
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*N [tauq, taup] + M*NB [work]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT]
*
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 2*N [tauq, taup] + N [work]
* CWorkspace: prefer 2*N [tauq, taup] + N*NB [work]
* RWorkspace: need N [e] + N*N [RU] + N*N [RVT]
*
CALL 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 >> M, JOBZ='N')
* No singular vectors to be computed
*
ITAU = 1
NWORK = ITAU + M
*
* Compute A=L*Q
* CWorkspace: need M [tau] + M [work]
* CWorkspace: prefer M [tau] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 2*M [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + 2*M*NB [work]
* RWorkspace: need M [e]
*
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: need 0
* RWorkspace: need M [e] + BDSPAC
*
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 >> 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 M*M [VT] + M*M [L] + M [tau] + M [work]
* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [VT] + M*M [L] + M [tau] + M [work]
* CWorkspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [VT] + M*M [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
* RWorkspace: need M [e]
*
CALL 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 M [e] + M*M [RU] + M*M [RVT] + 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 M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 M*M [VT] + M*M [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + M*M [L] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 M*M [VT] + M*M [L]
* CWorkspace: prefer M*M [VT] + M*N [L]
* RWorkspace: need 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 >> M, JOBZ='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IL = 1
*
* WORK(IL) is M by M
*
LDWRKL = M
ITAU = IL + LDWRKL*M
NWORK = ITAU + M
*
* Compute A=L*Q
* CWorkspace: need M*M [L] + M [tau] + M [work]
* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [L] + M [tau] + M [work]
* CWorkspace: prefer M*M [L] + M [tau] + M*NB [work]
* RWorkspace: need 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 [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + 2*M*NB [work]
* RWorkspace: need M [e]
*
CALL 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 M [e] + M*M [RU] + M*M [RVT] + 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 [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 [L] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [L] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 [L]
* RWorkspace: need 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 4t (N >> M, JOBZ='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IVT = 1
*
* WORK(IVT) is M by M
*
LDWKVT = M
ITAU = IVT + LDWKVT*M
NWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* CWorkspace: need M*M [VT] + M [tau] + M [work]
* CWorkspace: prefer M*M [VT] + M [tau] + M*NB [work]
* RWorkspace: need 0
*
CALL 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*M [VT] + M [tau] + N [work]
* CWorkspace: prefer M*M [VT] + M [tau] + N*NB [work]
* RWorkspace: need 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 [VT] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + 2*M*NB [work]
* RWorkspace: need M [e]
*
CALL 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 M [e] + M*M [RU] + M*M [RVT] + 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 [VT] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 [VT] + 2*M [tauq, taup] + M [work]
* CWorkspace: prefer M*M [VT] + 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 [VT]
* RWorkspace: need 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 >> 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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
* RWorkspace: need M [e]
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
*
IF( WNTQN ) THEN
*
* Path 5tn (N >> M, JOBZ='N')
* Compute singular values only
* CWorkspace: need 0
* RWorkspace: need M [e] + BDSPAC
*
CALL 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
*
* Path 5to (N >> M, JOBZ='O')
* Copy A to U, generate Q
* CWorkspace: need 2*M [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 M [e] + M*M [RVT] + M*M [RU] + 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 2*M [tauq, taup] + M*M [VT]
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
*
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 2*M [tauq, taup] + M*M [VT]
* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork]
* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
*
NRWORK = IRU
DO 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
*
* Path 5ts (N >> M, JOBZ='S')
* Copy A to U, generate Q
* CWorkspace: need 2*M [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 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 M [e] + M*M [RVT] + M*M [RU] + 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 M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
*
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 [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
*
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
*
* Path 5ta (N >> M, JOBZ='A')
* Copy A to U, generate Q
* CWorkspace: need 2*M [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
* RWorkspace: need 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 M [e] + M*M [RVT] + M*M [RU] + 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 M [e] + M*M [RVT] + M*M [RU] + 2*M*M [rwork]
*
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 [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
*
NRWORK = IRU
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 > 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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*M [tauq, taup] + (M+N)*NB [work]
* RWorkspace: need M [e]
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
$ IERR )
IF( WNTQN ) THEN
*
* Path 6tn (N > M, JOBZ='N')
* Compute singular values only
* CWorkspace: need 0
* RWorkspace: need M [e] + BDSPAC
*
CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM,1,DUM,1,
$ DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
ELSE IF( WNTQO ) THEN
* Path 6to (N > M, JOBZ='O')
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 M [e] + M*M [RVT] + M*M [RU] + 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 [tauq, taup] + M*M [VT] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU]
*
CALL 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
*
* Path 6to-fast
* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
* Overwrite WORK(IVT) by right singular vectors of A,
* copying to A
* CWorkspace: need 2*M [tauq, taup] + M*N [VT] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT] + M*NB [work]
* RWorkspace: need M [e] + M*M [RVT]
*
CALL 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
*
* Path 6to-slow
* Generate P**H in A
* CWorkspace: need 2*M [tauq, taup] + M*M [VT] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*M [VT] + M*NB [work]
* RWorkspace: need 0
*
CALL 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 2*M [tauq, taup] + M*M [VT]
* CWorkspace: prefer 2*M [tauq, taup] + M*N [VT]
* RWorkspace: need M [e] + M*M [RVT] + 2*M*M [rwork]
* RWorkspace: prefer M [e] + M*M [RVT] + 2*M*N [rwork] < M + 5*M*M since N < 2*M here
*
NRWORK = IRU
DO 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
*
* Path 6ts (N > M, JOBZ='S')
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(IRVT)
* CWorkspace: need 0
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU]
*
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 2*M [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need M [e] + M*M [RVT]
*
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
*
* Path 6ta (N > M, JOBZ='A')
* Perform bidiagonal SVD, computing left singular vectors
* of bidiagonal matrix in RWORK(IRU) and computing right
* singular vectors of bidiagonal matrix in RWORK(IRVT)
* CWorkspace: need 0
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU] + BDSPAC
*
IRVT = NRWORK
IRU = IRVT + M*M
NRWORK = IRU + M*M
*
CALL 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 [tauq, taup] + M [work]
* CWorkspace: prefer 2*M [tauq, taup] + M*NB [work]
* RWorkspace: need M [e] + M*M [RVT] + M*M [RU]
*
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 [tauq, taup] + N [work]
* CWorkspace: prefer 2*M [tauq, taup] + N*NB [work]
* RWorkspace: need M [e] + M*M [RVT]
*
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 ) = DROUNDUP_LWORK( MAXWRK )
*
RETURN
*
* End of ZGESDD
*
END
*> \addtogroup gesv
*>
*> \brief <b> ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver) </b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesv.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup gesv
*
* =====================================================================
SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
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 <b> ZGESVD computes the singular value decomposition (SVD) for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESVD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesvd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesvd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesvd.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup gesvd
*
* =====================================================================
SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, WORK, LWORK, RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
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 = INT( CDUM(1) )
* Compute space needed for ZUNGQR
CALL ZUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGQR_N = INT( CDUM(1) )
CALL ZUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGQR_M = INT( 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 = INT( CDUM(1) )
* Compute space needed for ZUNGBR
CALL ZUNGBR( 'P', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P = INT( CDUM(1) )
CALL ZUNGBR( 'Q', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q = INT( 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 = INT( 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 = INT( 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 = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
END IF
IF( .NOT.WNTVN ) THEN
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
END IF
MINWRK = 2*N + M
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 = INT( CDUM(1) )
* Compute space needed for ZUNGLQ
CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGLQ_N = INT( CDUM(1) )
CALL ZUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGLQ_M = INT( 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 = INT( 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 = INT( 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 = INT( 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 = INT( 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 = INT( 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 = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
END IF
IF( .NOT.WNTUN ) THEN
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
END IF
MINWRK = 2*M + N
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
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2,
$ 1 ),
$ LDA )
END IF
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
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* 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
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* 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
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* 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
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* 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> ZGESVX computes the solution to system of linear equations A * X = B for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESVX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgesvx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgesvx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgesvx.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
* EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
* WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER EQUED, FACT, TRANS
* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ),
* $ RWORK( * )
* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESVX uses the LU factorization to compute 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.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
* =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'E', real scaling factors are computed to equilibrate
*> the system:
*> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
*> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
*> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
*> Whether or not the system will be equilibrated depends on the
*> scaling of the matrix A, but if equilibration is used, A is
*> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
*> or diag(C)*B (if TRANS = 'T' or 'C').
*>
*> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
*> matrix A (after equilibration if FACT = 'E') as
*> A = P * L * U,
*> where P is a permutation matrix, L is a unit lower triangular
*> matrix, and U is upper triangular.
*>
*> 3. If some U(i,i)=0, so that U is exactly singular, then the routine
*> returns with INFO = i. Otherwise, the factored form of A is used
*> to estimate the condition number of the matrix A. If the
*> reciprocal of the condition number is less than machine precision,
*> INFO = N+1 is returned as a warning, but the routine still goes on
*> to solve for X and compute error bounds as described below.
*>
*> 4. The system of equations is solved for X using the factored form
*> of A.
*>
*> 5. Iterative refinement is applied to improve the computed solution
*> matrix and calculate error bounds and backward error estimates
*> for it.
*>
*> 6. If equilibration was used, the matrix X is premultiplied by
*> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
*> that it solves the original system before equilibration.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] FACT
*> \verbatim
*> FACT is CHARACTER*1
*> Specifies whether or not the factored form of the matrix A is
*> supplied on entry, and if not, whether the matrix A should be
*> equilibrated before it is factored.
*> = 'F': On entry, AF and IPIV contain the factored form of A.
*> If EQUED is not 'N', the matrix A has been
*> equilibrated with scaling factors given by R and C.
*> A, AF, and IPIV are not modified.
*> = 'N': The matrix A will be copied to AF and factored.
*> = 'E': The matrix A will be equilibrated if necessary, then
*> copied to AF and factored.
*> \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] 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 matrices B and X. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
*> not 'N', then A must have been equilibrated by the scaling
*> factors in R and/or C. A is not modified if FACT = 'F' or
*> 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*>
*> On exit, if EQUED .ne. 'N', A is scaled as follows:
*> EQUED = 'R': A := diag(R) * A
*> EQUED = 'C': A := A * diag(C)
*> EQUED = 'B': A := diag(R) * A * diag(C).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] AF
*> \verbatim
*> AF is COMPLEX*16 array, dimension (LDAF,N)
*> If FACT = 'F', then AF is an input argument and on entry
*> contains the factors L and U from the factorization
*> A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then
*> AF is the factored form of the equilibrated matrix A.
*>
*> If FACT = 'N', then AF is an output argument and on exit
*> returns the factors L and U from the factorization A = P*L*U
*> of the original matrix A.
*>
*> If FACT = 'E', then AF is an output argument and on exit
*> returns the factors L and U from the factorization A = P*L*U
*> of the equilibrated matrix A (see the description of A for
*> the form of the equilibrated matrix).
*> \endverbatim
*>
*> \param[in] LDAF
*> \verbatim
*> LDAF is INTEGER
*> The leading dimension of the array AF. LDAF >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> If FACT = 'F', then IPIV is an input argument and on entry
*> contains the pivot indices from the factorization A = P*L*U
*> as computed by ZGETRF; row i of the matrix was interchanged
*> with row IPIV(i).
*>
*> If FACT = 'N', then IPIV is an output argument and on exit
*> contains the pivot indices from the factorization A = P*L*U
*> of the original matrix A.
*>
*> If FACT = 'E', then IPIV is an output argument and on exit
*> contains the pivot indices from the factorization A = P*L*U
*> of the equilibrated matrix A.
*> \endverbatim
*>
*> \param[in,out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies the form of equilibration that was done.
*> = 'N': No equilibration (always true if FACT = 'N').
*> = 'R': Row equilibration, i.e., A has been premultiplied by
*> diag(R).
*> = 'C': Column equilibration, i.e., A has been postmultiplied
*> by diag(C).
*> = 'B': Both row and column equilibration, i.e., A has been
*> replaced by diag(R) * A * diag(C).
*> EQUED is an input argument if FACT = 'F'; otherwise, it is an
*> output argument.
*> \endverbatim
*>
*> \param[in,out] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (N)
*> The row scale factors for A. If EQUED = 'R' or 'B', A is
*> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
*> is not accessed. R is an input argument if FACT = 'F';
*> otherwise, R is an output argument. If FACT = 'F' and
*> EQUED = 'R' or 'B', each element of R must be positive.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> The column scale factors for A. If EQUED = 'C' or 'B', A is
*> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
*> is not accessed. C is an input argument if FACT = 'F';
*> otherwise, C is an output argument. If FACT = 'F' and
*> EQUED = 'C' or 'B', each element of C must be positive.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS right hand side matrix B.
*> On exit,
*> if EQUED = 'N', B is not modified;
*> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
*> diag(R)*B;
*> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
*> overwritten by diag(C)*B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
*> to the original system of equations. Note that A and B are
*> modified on exit if EQUED .ne. 'N', and the solution to the
*> equilibrated system is inv(diag(C))*X if TRANS = 'N' and
*> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
*> and EQUED = 'R' or 'B'.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The estimate of the reciprocal condition number of the matrix
*> A after equilibration (if done). If RCOND is less than the
*> machine precision (in particular, if RCOND = 0), the matrix
*> is singular to working precision. This condition is
*> indicated by a return code of INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,2*N))
*> On exit, RWORK(1) contains the reciprocal pivot growth
*> factor norm(A)/norm(U). The "max absolute element" norm is
*> used. If RWORK(1) is much less than 1, then the stability
*> of the LU factorization of the (equilibrated) matrix A
*> could be poor. This also means that the solution X, condition
*> estimator RCOND, and forward error bound FERR could be
*> unreliable. If factorization fails with 0<INFO<=N, then
*> RWORK(1) contains the reciprocal pivot growth factor for the
*> leading INFO columns of A.
*> \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, and i is
*> <= N: U(i,i) is exactly zero. The factorization has
*> been completed, but the factor U is exactly
*> singular, so the solution and error bounds
*> could not be computed. RCOND = 0 is returned.
*> = N+1: U is nonsingular, but RCOND is less than machine
*> precision, meaning that the matrix is singular
*> to working precision. Nevertheless, the
*> solution and error bounds are computed because
*> there are a number of situations where the
*> computed solution can be more accurate than the
*> value of RCOND would suggest.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gesvx
*
* =====================================================================
SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF,
$ IPIV,
$ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, TRANS
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ),
$ RWORK( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
CHARACTER NORM
INTEGER I, INFEQU, J
DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
$ ROWCND, RPVGRW, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANGE, ZLANTR
EXTERNAL LSAME, DLAMCH, ZLANGE, ZLANTR
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGECON, ZGEEQU, ZGERFS, ZGETRF,
$ ZGETRS,
$ ZLACPY, ZLAQGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
NOTRAN = LSAME( TRANS, 'N' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
ROWEQU = .FALSE.
COLEQU = .FALSE.
ELSE
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND.
$ .NOT.EQUIL .AND.
$ .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -10
ELSE
IF( ROWEQU ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 10 J = 1, N
RCMIN = MIN( RCMIN, R( J ) )
RCMAX = MAX( RCMAX, R( J ) )
10 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -11
ELSE IF( N.GT.0 ) THEN
ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
ROWCND = ONE
END IF
END IF
IF( COLEQU .AND. INFO.EQ.0 ) THEN
RCMIN = BIGNUM
RCMAX = ZERO
DO 20 J = 1, N
RCMIN = MIN( RCMIN, C( J ) )
RCMAX = MAX( RCMAX, C( J ) )
20 CONTINUE
IF( RCMIN.LE.ZERO ) THEN
INFO = -12
ELSE IF( N.GT.0 ) THEN
COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
ELSE
COLCND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL ZGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL ZLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
END IF
END IF
*
* Scale the right hand side.
*
IF( NOTRAN ) THEN
IF( ROWEQU ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = R( I )*B( I, J )
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( COLEQU ) THEN
DO 60 J = 1, NRHS
DO 50 I = 1, N
B( I, J ) = C( I )*B( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the LU factorization of A.
*
CALL ZLACPY( 'Full', N, N, A, LDA, AF, LDAF )
CALL ZGETRF( N, N, AF, LDAF, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 ) THEN
*
* Compute the reciprocal pivot growth factor of the
* leading rank-deficient INFO columns of A.
*
RPVGRW = ZLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
$ RWORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ZLANGE( 'M', N, INFO, A, LDA, RWORK ) /
$ RPVGRW
END IF
RWORK( 1 ) = RPVGRW
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A and the
* reciprocal pivot growth factor RPVGRW.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = ZLANGE( NORM, N, N, A, LDA, RWORK )
RPVGRW = ZLANTR( 'M', 'U', 'N', N, N, AF, LDAF, RWORK )
IF( RPVGRW.EQ.ZERO ) THEN
RPVGRW = ONE
ELSE
RPVGRW = ZLANGE( 'M', N, N, A, LDA, RWORK ) / RPVGRW
END IF
*
* Compute the reciprocal of the condition number of A.
*
CALL ZGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* Compute the solution matrix X.
*
CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL ZGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
$ LDX, FERR, BERR, WORK, RWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( NOTRAN ) THEN
IF( COLEQU ) THEN
DO 80 J = 1, NRHS
DO 70 I = 1, N
X( I, J ) = C( I )*X( I, J )
70 CONTINUE
80 CONTINUE
DO 90 J = 1, NRHS
FERR( J ) = FERR( J ) / COLCND
90 CONTINUE
END IF
ELSE IF( ROWEQU ) THEN
DO 110 J = 1, NRHS
DO 100 I = 1, N
X( I, J ) = R( I )*X( I, J )
100 CONTINUE
110 CONTINUE
DO 120 J = 1, NRHS
FERR( J ) = FERR( J ) / ROWCND
120 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RWORK( 1 ) = RPVGRW
RETURN
*
* End of ZGESVX
*
END
*> \brief \b ZGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETC2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetc2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetc2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetc2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETC2 computes an LU factorization, using complete pivoting, of the
*> n-by-n matrix A. The factorization has the form A = P * L * U * Q,
*> where P and Q are permutation matrices, L is lower triangular with
*> unit diagonal elements and U is upper triangular.
*>
*> This is a level 1 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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 to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U*Q; the unit diagonal elements of L are not stored.
*> If U(k, k) appears to be less than SMIN, U(k, k) is given the
*> value of SMIN, giving a nonsingular perturbed system.
*> \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; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, U(k, k) is likely to produce overflow if
*> one tries to solve for x in Ax = b. So U is perturbed
*> to avoid the overflow.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup getc2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, IPV, J, JP, JPV
DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX
* ..
* .. External Subroutines ..
EXTERNAL ZGERU, ZSWAP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DCMPLX, MAX
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
* Handle the case N=1 by itself
*
IF( N.EQ.1 ) THEN
IPIV( 1 ) = 1
JPIV( 1 ) = 1
IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN
INFO = 1
A( 1, 1 ) = DCMPLX( SMLNUM, ZERO )
END IF
RETURN
END IF
*
* Factorize A using complete pivoting.
* Set pivots less than SMIN to SMIN
*
DO 40 I = 1, N - 1
*
* Find max element in matrix A
*
XMAX = ZERO
DO 20 JP = I, N
DO 10 IP = I, N
IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( A( IP, JP ) )
IPV = IP
JPV = JP
END IF
10 CONTINUE
20 CONTINUE
IF( I.EQ.1 )
$ SMIN = MAX( EPS*XMAX, SMLNUM )
*
* Swap rows
*
IF( IPV.NE.I )
$ CALL ZSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
IPIV( I ) = IPV
*
* Swap columns
*
IF( JPV.NE.I )
$ CALL ZSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
JPIV( I ) = JPV
*
* Check for singularity
*
IF( ABS( A( I, I ) ).LT.SMIN ) THEN
INFO = I
A( I, I ) = DCMPLX( SMIN, ZERO )
END IF
DO 30 J = I + 1, N
A( J, I ) = A( J, I ) / A( I, I )
30 CONTINUE
CALL ZGERU( N-I, N-I, -DCMPLX( ONE ), A( I+1, I ), 1,
$ A( I, I+1 ), LDA, A( I+1, I+1 ), LDA )
40 CONTINUE
*
IF( ABS( A( N, N ) ).LT.SMIN ) THEN
INFO = N
A( N, N ) = DCMPLX( SMIN, ZERO )
END IF
*
* Set last pivots to N
*
IPIV( N ) = N
JPIV( N ) = N
*
RETURN
*
* End of ZGETC2
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetf2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup getf2
*
* =====================================================================
SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 J, JP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IZAMAX
EXTERNAL DLAMCH, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGERU, ZRSCL, 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 )
$ CALL ZRSCL( M-J, A( J, J ), A( J+1, J ), 1 )
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetrf.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup getrf
*
* =====================================================================
SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, ZGETRF2, 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 ZGETRF2( 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 ZGETRF2( 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 ZGETRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRF2 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 recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = min(m,n)/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> [ A11 ]
*> The subroutine calls itself to factor [ --- ],
*> [ A12 ]
*> [ A12 ]
*> do the swaps on [ --- ], solve A12, update A22,
*> [ A22 ]
*>
*> then calls itself to factor A22 and do the swaps on A21.
*>
*> \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.
*
*> \ingroup getrf2
*
* =====================================================================
RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
COMPLEX*16 TEMP
INTEGER I, IINFO, N1, N2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IZAMAX
EXTERNAL DLAMCH, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA
* ..
* .. 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( 'ZGETRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
IF ( M.EQ.1 ) THEN
*
* Use unblocked code for one row case
* Just need to handle IPIV and INFO
*
IPIV( 1 ) = 1
IF ( A(1,1).EQ.ZERO )
$ INFO = 1
*
ELSE IF( N.EQ.1 ) THEN
*
* Use unblocked code for one column case
*
*
* Compute machine safe minimum
*
SFMIN = DLAMCH('S')
*
* Find pivot and test for singularity
*
I = IZAMAX( M, A( 1, 1 ), 1 )
IPIV( 1 ) = I
IF( A( I, 1 ).NE.ZERO ) THEN
*
* Apply the interchange
*
IF( I.NE.1 ) THEN
TEMP = A( 1, 1 )
A( 1, 1 ) = A( I, 1 )
A( I, 1 ) = TEMP
END IF
*
* Compute elements 2:M of the column
*
IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN
CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )
ELSE
DO 10 I = 1, M-1
A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )
10 CONTINUE
END IF
*
ELSE
INFO = 1
END IF
ELSE
*
* Use recursive code
*
N1 = MIN( M, N ) / 2
N2 = N-N1
*
* [ A11 ]
* Factor [ --- ]
* [ A21 ]
*
CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO )
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* [ A12 ]
* Apply interchanges to [ --- ]
* [ A22 ]
*
CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )
*
* Solve A12
*
CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA,
$ A( 1, N1+1 ), LDA )
*
* Update A22
*
CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )
*
* Factor A22
*
CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ),
$ IINFO )
*
* Adjust INFO and the pivot indices
*
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + N1
DO 20 I = N1+1, MIN( M, N )
IPIV( I ) = IPIV( I ) + N1
20 CONTINUE
*
* Apply interchanges to A21
*
CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )
*
END IF
RETURN
*
* End of ZGETRF2
*
END
*> \brief \b ZGETRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRI computes the inverse of a matrix using the LU factorization
*> computed by ZGETRF.
*>
*> This method inverts U and then computes inv(A) by solving the system
*> inv(A)*L = inv(U) for inv(A).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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 factors L and U from the factorization
*> A = P*L*U as computed by ZGETRF.
*> On exit, if INFO = 0, the inverse of the original matrix A.
*> \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[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO=0, then 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 optimal performance LWORK >= N*NB, where NB is
*> the optimal blocksize 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] 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 matrix is
*> singular and its inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup getri
*
* =====================================================================
SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), 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, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM,
$ ZTRTRI
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 )
LWKOPT = MAX( 1, N*NB )
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular,
* and the inverse is not computed.
*
CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1,
$ -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL ZGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGETRI
*
END
*> \brief \b ZGETRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgetrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgetrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgetrs.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup getrs
*
* =====================================================================
SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 \b ZGGBAK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGBAK + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggbak.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggbak.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggbak.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
* LDV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB, SIDE
* INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION LSCALE( * ), RSCALE( * )
* COMPLEX*16 V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGGBAK forms the right or left eigenvectors of a complex generalized
*> eigenvalue problem A*x = lambda*B*x, by backward transformation on
*> the computed eigenvectors of the balanced pair of matrices output by
*> ZGGBAL.
*> \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 ZGGBAL.
*> \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 ZGGBAL.
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in] LSCALE
*> \verbatim
*> LSCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and/or scaling factors applied
*> to the left side of A and B, as returned by ZGGBAL.
*> \endverbatim
*>
*> \param[in] RSCALE
*> \verbatim
*> RSCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and/or scaling factors applied
*> to the right side of A and B, as returned by ZGGBAL.
*> \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 ZTGEVC.
*> On exit, V is overwritten by the transformed eigenvectors.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the matrix 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.
*
*> \ingroup ggbak
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> See R.C. Ward, Balancing the generalized eigenvalue problem,
*> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M,
$ V,
$ LDV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION LSCALE( * ), RSCALE( * )
COMPLEX*16 V( LDV, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, K
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, INT
* ..
* .. Executable Statements ..
*
* 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 ) THEN
INFO = -4
ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
INFO = -4
ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
$ THEN
INFO = -5
ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -8
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGGBAK', -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
*
* Backward transformation on right eigenvectors
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
10 CONTINUE
END IF
*
* Backward transformation on left eigenvectors
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
20 CONTINUE
END IF
END IF
*
* Backward permutation
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
* Backward permutation on right eigenvectors
*
IF( RIGHTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 50
DO 40 I = ILO - 1, 1, -1
K = INT(RSCALE( I ))
IF( K.EQ.I )
$ GO TO 40
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
*
50 CONTINUE
IF( IHI.EQ.N )
$ GO TO 70
DO 60 I = IHI + 1, N
K = INT(RSCALE( I ))
IF( K.EQ.I )
$ GO TO 60
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
60 CONTINUE
END IF
*
* Backward permutation on left eigenvectors
*
70 CONTINUE
IF( LEFTV ) THEN
IF( ILO.EQ.1 )
$ GO TO 90
DO 80 I = ILO - 1, 1, -1
K = INT(LSCALE( I ))
IF( K.EQ.I )
$ GO TO 80
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
80 CONTINUE
*
90 CONTINUE
IF( IHI.EQ.N )
$ GO TO 110
DO 100 I = IHI + 1, N
K = INT(LSCALE( I ))
IF( K.EQ.I )
$ GO TO 100
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
100 CONTINUE
END IF
END IF
*
110 CONTINUE
*
RETURN
*
* End of ZGGBAK
*
END
*> \brief \b ZGGBAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGBAL + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggbal.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggbal.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggbal.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
* RSCALE, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB
* INTEGER IHI, ILO, INFO, LDA, LDB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGGBAL balances a pair of general complex matrices (A,B). This
*> involves, first, permuting A and B by similarity transformations 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 matrices, and improve the
*> accuracy of the computed eigenvalues and/or eigenvectors in the
*> generalized eigenvalue problem A*x = lambda*B*x.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies the operations to be performed on A and B:
*> = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
*> and RSCALE(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 matrices A and B. 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.
*> \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,N)
*> On entry, the input matrix B.
*> On exit, B is overwritten by the balanced matrix.
*> If JOB = 'N', B is not referenced.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*> IHI is INTEGER
*> ILO and IHI are set to integers such that on exit
*> A(i,j) = 0 and B(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] LSCALE
*> \verbatim
*> LSCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and scaling factors applied
*> to the left side of A and B. If P(j) is the index of the
*> row interchanged with row j, and D(j) is the scaling factor
*> applied to row j, then
*> LSCALE(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] RSCALE
*> \verbatim
*> RSCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and scaling factors applied
*> to the right side of A and B. If P(j) is the index of the
*> column interchanged with column j, and D(j) is the scaling
*> factor applied to column j, then
*> RSCALE(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] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (lwork)
*> lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
*> at least 1 when JOB = 'N' or 'P'.
*> \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.
*
*> \ingroup ggbal
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> See R.C. WARD, Balancing the generalized eigenvalue problem,
*> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
$ RSCALE, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
DOUBLE PRECISION THREE, SCLFAC
PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
$ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
$ M, NR, NRP2
DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
$ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
$ SFMIN, SUM, T, TA, TB, TC
COMPLEX*16 CDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DDOT, DLAMCH
EXTERNAL LSAME, IZAMAX, DDOT, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN
* ..
* .. 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
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGGBAL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
ILO = 1
IHI = N
RETURN
END IF
*
IF( N.EQ.1 ) THEN
ILO = 1
IHI = N
LSCALE( 1 ) = ONE
RSCALE( 1 ) = ONE
RETURN
END IF
*
IF( LSAME( JOB, 'N' ) ) THEN
ILO = 1
IHI = N
DO 10 I = 1, N
LSCALE( I ) = ONE
RSCALE( I ) = ONE
10 CONTINUE
RETURN
END IF
*
K = 1
L = N
IF( LSAME( JOB, 'S' ) )
$ GO TO 190
*
GO TO 30
*
* Permute the matrices A and B to isolate the eigenvalues.
*
* Find row with one nonzero in columns 1 through L
*
20 CONTINUE
L = LM1
IF( L.NE.1 )
$ GO TO 30
*
RSCALE( 1 ) = 1
LSCALE( 1 ) = 1
GO TO 190
*
30 CONTINUE
LM1 = L - 1
DO 80 I = L, 1, -1
DO 40 J = 1, LM1
JP1 = J + 1
IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
$ GO TO 50
40 CONTINUE
J = L
GO TO 70
*
50 CONTINUE
DO 60 J = JP1, L
IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
$ GO TO 80
60 CONTINUE
J = JP1 - 1
*
70 CONTINUE
M = L
IFLOW = 1
GO TO 160
80 CONTINUE
GO TO 100
*
* Find column with one nonzero in rows K through N
*
90 CONTINUE
K = K + 1
*
100 CONTINUE
DO 150 J = K, L
DO 110 I = K, LM1
IP1 = I + 1
IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
$ GO TO 120
110 CONTINUE
I = L
GO TO 140
120 CONTINUE
DO 130 I = IP1, L
IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
$ GO TO 150
130 CONTINUE
I = IP1 - 1
140 CONTINUE
M = K
IFLOW = 2
GO TO 160
150 CONTINUE
GO TO 190
*
* Permute rows M and I
*
160 CONTINUE
LSCALE( M ) = I
IF( I.EQ.M )
$ GO TO 170
CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
*
* Permute columns M and J
*
170 CONTINUE
RSCALE( M ) = J
IF( J.EQ.M )
$ GO TO 180
CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
*
180 CONTINUE
GO TO ( 20, 90 )IFLOW
*
190 CONTINUE
ILO = K
IHI = L
*
IF( LSAME( JOB, 'P' ) ) THEN
DO 195 I = ILO, IHI
LSCALE( I ) = ONE
RSCALE( I ) = ONE
195 CONTINUE
RETURN
END IF
*
IF( ILO.EQ.IHI )
$ RETURN
*
* Balance the submatrix in rows ILO to IHI.
*
NR = IHI - ILO + 1
DO 200 I = ILO, IHI
RSCALE( I ) = ZERO
LSCALE( I ) = ZERO
*
WORK( I ) = ZERO
WORK( I+N ) = ZERO
WORK( I+2*N ) = ZERO
WORK( I+3*N ) = ZERO
WORK( I+4*N ) = ZERO
WORK( I+5*N ) = ZERO
200 CONTINUE
*
* Compute right side vector in resulting linear equations
*
BASL = LOG10( SCLFAC )
DO 240 I = ILO, IHI
DO 230 J = ILO, IHI
IF( A( I, J ).EQ.CZERO ) THEN
TA = ZERO
GO TO 210
END IF
TA = LOG10( CABS1( A( I, J ) ) ) / BASL
*
210 CONTINUE
IF( B( I, J ).EQ.CZERO ) THEN
TB = ZERO
GO TO 220
END IF
TB = LOG10( CABS1( B( I, J ) ) ) / BASL
*
220 CONTINUE
WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
230 CONTINUE
240 CONTINUE
*
COEF = ONE / DBLE( 2*NR )
COEF2 = COEF*COEF
COEF5 = HALF*COEF2
NRP2 = NR + 2
BETA = ZERO
IT = 1
*
* Start generalized conjugate gradient iteration
*
250 CONTINUE
*
GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
$ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
*
EW = ZERO
EWC = ZERO
DO 260 I = ILO, IHI
EW = EW + WORK( I+4*N )
EWC = EWC + WORK( I+5*N )
260 CONTINUE
*
GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
IF( GAMMA.EQ.ZERO )
$ GO TO 350
IF( IT.NE.1 )
$ BETA = GAMMA / PGAMMA
T = COEF5*( EWC-THREE*EW )
TC = COEF5*( EW-THREE*EWC )
*
CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
*
CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
*
DO 270 I = ILO, IHI
WORK( I ) = WORK( I ) + TC
WORK( I+N ) = WORK( I+N ) + T
270 CONTINUE
*
* Apply matrix to vector
*
DO 300 I = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 290 J = ILO, IHI
IF( A( I, J ).EQ.CZERO )
$ GO TO 280
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
280 CONTINUE
IF( B( I, J ).EQ.CZERO )
$ GO TO 290
KOUNT = KOUNT + 1
SUM = SUM + WORK( J )
290 CONTINUE
WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
300 CONTINUE
*
DO 330 J = ILO, IHI
KOUNT = 0
SUM = ZERO
DO 320 I = ILO, IHI
IF( A( I, J ).EQ.CZERO )
$ GO TO 310
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
310 CONTINUE
IF( B( I, J ).EQ.CZERO )
$ GO TO 320
KOUNT = KOUNT + 1
SUM = SUM + WORK( I+N )
320 CONTINUE
WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
330 CONTINUE
*
SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
$ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
ALPHA = GAMMA / SUM
*
* Determine correction to current iteration
*
CMAX = ZERO
DO 340 I = ILO, IHI
COR = ALPHA*WORK( I+N )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
LSCALE( I ) = LSCALE( I ) + COR
COR = ALPHA*WORK( I )
IF( ABS( COR ).GT.CMAX )
$ CMAX = ABS( COR )
RSCALE( I ) = RSCALE( I ) + COR
340 CONTINUE
IF( CMAX.LT.HALF )
$ GO TO 350
*
CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ),
$ 1 )
CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ),
$ 1 )
*
PGAMMA = GAMMA
IT = IT + 1
IF( IT.LE.NRP2 )
$ GO TO 250
*
* End generalized conjugate gradient iteration
*
350 CONTINUE
SFMIN = DLAMCH( 'S' )
SFMAX = ONE / SFMIN
LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
LSFMAX = INT( LOG10( SFMAX ) / BASL )
DO 360 I = ILO, IHI
IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA )
RAB = ABS( A( I, IRAB+ILO-1 ) )
IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB )
RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
IR = INT(LSCALE( I ) + SIGN( HALF, LSCALE( I ) ))
IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
LSCALE( I ) = SCLFAC**IR
ICAB = IZAMAX( IHI, A( 1, I ), 1 )
CAB = ABS( A( ICAB, I ) )
ICAB = IZAMAX( IHI, B( 1, I ), 1 )
CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
JC = INT(RSCALE( I ) + SIGN( HALF, RSCALE( I ) ))
JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
RSCALE( I ) = SCLFAC**JC
360 CONTINUE
*
* Row scaling of matrices A and B
*
DO 370 I = ILO, IHI
CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
370 CONTINUE
*
* Column scaling of matrices A and B
*
DO 380 J = ILO, IHI
CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
380 CONTINUE
*
RETURN
*
* End of ZGGBAL
*
END
*> \brief <b> ZGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGES + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgges.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgges.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgges.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
* SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
* LWORK, RWORK, BWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVSL, JOBVSR, SORT
* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
* ..
* .. Array Arguments ..
* LOGICAL BWORK( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
* $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
* $ WORK( * )
* ..
* .. Function Arguments ..
* LOGICAL SELCTG
* EXTERNAL SELCTG
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGGES computes for a pair of N-by-N complex nonsymmetric matrices
*> (A,B), the generalized eigenvalues, the generalized complex Schur
*> form (S, T), and optionally left and/or right Schur vectors (VSL
*> and VSR). This gives the generalized Schur factorization
*>
*> (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
*>
*> where (VSR)**H is the conjugate-transpose of VSR.
*>
*> Optionally, it also orders the eigenvalues so that a selected cluster
*> of eigenvalues appears in the leading diagonal blocks of the upper
*> triangular matrix S and the upper triangular matrix T. The leading
*> columns of VSL and VSR then form an unitary basis for the
*> corresponding left and right eigenspaces (deflating subspaces).
*>
*> (If only the generalized eigenvalues are needed, use the driver
*> ZGGEV instead, which is faster.)
*>
*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
*> or a ratio alpha/beta = w, such that A - w*B is singular. It is
*> usually represented as the pair (alpha,beta), as there is a
*> reasonable interpretation for beta=0, and even for both being zero.
*>
*> A pair of matrices (S,T) is in generalized complex Schur form if S
*> and T are upper triangular and, in addition, the diagonal elements
*> of T are non-negative real numbers.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVSL
*> \verbatim
*> JOBVSL is CHARACTER*1
*> = 'N': do not compute the left Schur vectors;
*> = 'V': compute the left Schur vectors.
*> \endverbatim
*>
*> \param[in] JOBVSR
*> \verbatim
*> JOBVSR is CHARACTER*1
*> = 'N': do not compute the right Schur vectors;
*> = 'V': compute the right Schur vectors.
*> \endverbatim
*>
*> \param[in] SORT
*> \verbatim
*> SORT is CHARACTER*1
*> Specifies whether or not to order the eigenvalues on the
*> diagonal of the generalized Schur form.
*> = 'N': Eigenvalues are not ordered;
*> = 'S': Eigenvalues are ordered (see SELCTG).
*> \endverbatim
*>
*> \param[in] SELCTG
*> \verbatim
*> SELCTG is a LOGICAL FUNCTION of two COMPLEX*16 arguments
*> SELCTG must be declared EXTERNAL in the calling subroutine.
*> If SORT = 'N', SELCTG is not referenced.
*> If SORT = 'S', SELCTG is used to select eigenvalues to sort
*> to the top left of the Schur form.
*> An eigenvalue ALPHA(j)/BETA(j) is selected if
*> SELCTG(ALPHA(j),BETA(j)) is true.
*>
*> Note that a selected complex eigenvalue may no longer satisfy
*> SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
*> ordering may change the value of complex eigenvalues
*> (especially if the eigenvalue is ill-conditioned), in this
*> case INFO is set to N+2 (See INFO below).
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A, B, VSL, and VSR. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the first of the pair of matrices.
*> On exit, A has been overwritten by its generalized Schur
*> form S.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB, N)
*> On entry, the second of the pair of matrices.
*> On exit, B has been overwritten by its generalized Schur
*> form T.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] SDIM
*> \verbatim
*> SDIM is INTEGER
*> If SORT = 'N', SDIM = 0.
*> If SORT = 'S', SDIM = number of eigenvalues (after sorting)
*> for which SELCTG is true.
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*> BETA is COMPLEX*16 array, dimension (N)
*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
*> generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),
*> j=1,...,N are the diagonals of the complex Schur form (A,B)
*> output by ZGGES. The BETA(j) will be non-negative real.
*>
*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or
*> underflow, and BETA(j) may even be zero. Thus, the user
*> should avoid naively computing the ratio alpha/beta.
*> However, ALPHA will be always less than and usually
*> comparable with norm(A) in magnitude, and BETA always less
*> than and usually comparable with norm(B).
*> \endverbatim
*>
*> \param[out] VSL
*> \verbatim
*> VSL is COMPLEX*16 array, dimension (LDVSL,N)
*> If JOBVSL = 'V', VSL will contain the left Schur vectors.
*> Not referenced if JOBVSL = 'N'.
*> \endverbatim
*>
*> \param[in] LDVSL
*> \verbatim
*> LDVSL is INTEGER
*> The leading dimension of the matrix VSL. LDVSL >= 1, and
*> if JOBVSL = 'V', LDVSL >= N.
*> \endverbatim
*>
*> \param[out] VSR
*> \verbatim
*> VSR is COMPLEX*16 array, dimension (LDVSR,N)
*> If JOBVSR = 'V', VSR will contain the right Schur vectors.
*> Not referenced if JOBVSR = 'N'.
*> \endverbatim
*>
*> \param[in] LDVSR
*> \verbatim
*> LDVSR is INTEGER
*> The leading dimension of the matrix VSR. LDVSR >= 1, and
*> if JOBVSR = 'V', LDVSR >= 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 (8*N)
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*> BWORK is LOGICAL array, dimension (N)
*> Not referenced if SORT = 'N'.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> =1,...,N:
*> The QZ iteration failed. (A,B) are not in Schur
*> form, but ALPHA(j) and BETA(j) should be correct for
*> j=INFO+1,...,N.
*> > N: =N+1: other than QZ iteration failed in ZHGEQZ
*> =N+2: after reordering, roundoff changed values of
*> some complex eigenvalues so that leading
*> eigenvalues in the Generalized Schur form no
*> longer satisfy SELCTG=.TRUE. This could also
*> be caused due to scaling.
*> =N+3: reordering failed in ZTGSEN.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gges
*
* =====================================================================
SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B,
$ LDB,
$ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
$ LWORK, RWORK, BWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBVSL, JOBVSR, SORT
INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
$ WORK( * )
* ..
* .. Function Arguments ..
LOGICAL SELCTG
EXTERNAL SELCTG
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
$ LQUERY, WANTST
INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
$ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN,
$ LWKOPT
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
$ PVSR, SMLNUM
* ..
* .. Local Arrays ..
INTEGER IDUM( 1 )
DOUBLE PRECISION DIF( 2 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
$ ZHGEQZ,
$ ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, ZUNMQR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVSL, 'N' ) ) THEN
IJOBVL = 1
ILVSL = .FALSE.
ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
IJOBVL = 2
ILVSL = .TRUE.
ELSE
IJOBVL = -1
ILVSL = .FALSE.
END IF
*
IF( LSAME( JOBVSR, 'N' ) ) THEN
IJOBVR = 1
ILVSR = .FALSE.
ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
IJOBVR = 2
ILVSR = .TRUE.
ELSE
IJOBVR = -1
ILVSR = .FALSE.
END IF
*
WANTST = LSAME( SORT, 'S' )
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( ( .NOT.WANTST ) .AND.
$ ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
INFO = -3
ELSE IF( N.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
ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
INFO = -14
ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
INFO = -16
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
LWKMIN = MAX( 1, 2*N )
LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N,
$ 0 ) )
LWKOPT = MAX( LWKOPT, N +
$ N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) )
IF( ILVSL ) THEN
LWKOPT = MAX( LWKOPT, N +
$ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -18
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGGES ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SDIM = 0
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
*
IF( ILASCL )
$ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
*
IF( ILBSCL )
$ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrix to make it more nearly triangular
* (Real Workspace: need 6*N)
*
ILEFT = 1
IRIGHT = N + 1
IRWRK = IRIGHT + N
CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Complex Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
ICOLS = N + 1 - ILO
ITAU = 1
IWRK = ITAU + IROWS
CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Complex Workspace: need N, prefer N*NB)
*
CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VSL
* (Complex Workspace: need N, prefer N*NB)
*
IF( ILVSL ) THEN
CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
IF( IROWS.GT.1 ) THEN
CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VSL( ILO+1, ILO ), LDVSL )
END IF
CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VSR
*
IF( ILVSR )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
*
* Reduce to generalized Hessenberg form
* (Workspace: none needed)
*
CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
$ LDVSL, VSR, LDVSR, IERR )
*
SDIM = 0
*
* Perform QZ algorithm, computing Schur vectors if desired
* (Complex Workspace: need N)
* (Real Workspace: need N)
*
IWRK = ITAU
CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ),
$ LWORK+1-IWRK, RWORK( IRWRK ), IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 30
END IF
*
* Sort eigenvalues ALPHA/BETA if desired
* (Workspace: none needed)
*
IF( WANTST ) THEN
*
* Undo scaling on eigenvalues before selecting
*
IF( ILASCL )
$ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N,
$ IERR )
IF( ILBSCL )
$ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N,
$ IERR )
*
* Select eigenvalues
*
DO 10 I = 1, N
BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) )
10 CONTINUE
*
CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
$ ALPHA,
$ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR,
$ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR )
IF( IERR.EQ.1 )
$ INFO = N + 3
*
END IF
*
* Apply back-permutation to VSL and VSR
* (Workspace: none needed)
*
IF( ILVSL )
$ CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), N, VSL, LDVSL, IERR )
IF( ILVSR )
$ CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), N, VSR, LDVSR, IERR )
*
* Undo scaling
*
IF( ILASCL ) THEN
CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
END IF
*
IF( ILBSCL ) THEN
CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
END IF
*
IF( WANTST ) THEN
*
* Check if reordering is correct
*
LASTSL = .TRUE.
SDIM = 0
DO 20 I = 1, N
CURSL = SELCTG( ALPHA( I ), BETA( I ) )
IF( CURSL )
$ SDIM = SDIM + 1
IF( CURSL .AND. .NOT.LASTSL )
$ INFO = N + 2
LASTSL = CURSL
20 CONTINUE
*
END IF
*
30 CONTINUE
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZGGES
*
END
*> \brief <b> ZGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGEV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggev.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggev.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggev.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
* VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVL, JOBVR
* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
* $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
*> (A,B), the generalized eigenvalues, and optionally, the left and/or
*> right generalized eigenvectors.
*>
*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar
*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
*> singular. It is usually represented as the pair (alpha,beta), as
*> there is a reasonable interpretation for beta=0, and even for both
*> being zero.
*>
*> The right generalized eigenvector v(j) corresponding to the
*> generalized eigenvalue lambda(j) of (A,B) satisfies
*>
*> A * v(j) = lambda(j) * B * v(j).
*>
*> The left generalized eigenvector u(j) corresponding to the
*> generalized eigenvalues lambda(j) of (A,B) satisfies
*>
*> u(j)**H * A = lambda(j) * u(j)**H * B
*>
*> where u(j)**H is the conjugate-transpose of u(j).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVL
*> \verbatim
*> JOBVL is CHARACTER*1
*> = 'N': do not compute the left generalized eigenvectors;
*> = 'V': compute the left generalized eigenvectors.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*> JOBVR is CHARACTER*1
*> = 'N': do not compute the right generalized eigenvectors;
*> = 'V': compute the right generalized eigenvectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A, B, VL, and VR. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the matrix A in the pair (A,B).
*> On exit, A has been overwritten.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB, N)
*> On entry, the matrix B in the pair (A,B).
*> On exit, B has been overwritten.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*> BETA is COMPLEX*16 array, dimension (N)
*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
*> generalized eigenvalues.
*>
*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or
*> underflow, and BETA(j) may even be zero. Thus, the user
*> should avoid naively computing the ratio alpha/beta.
*> However, ALPHA will be always less than and usually
*> comparable with norm(A) in magnitude, and BETA always less
*> than and usually comparable with norm(B).
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,N)
*> If JOBVL = 'V', the left generalized eigenvectors u(j) are
*> stored one after another in the columns of VL, in the same
*> order as their eigenvalues.
*> Each eigenvector is scaled so the largest component has
*> abs(real part) + abs(imag. part) = 1.
*> Not referenced if JOBVL = 'N'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the matrix VL. LDVL >= 1, and
*> if JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,N)
*> If JOBVR = 'V', the right generalized eigenvectors v(j) are
*> stored one after another in the columns of VR, in the same
*> order as their eigenvalues.
*> Each eigenvector is scaled so the largest component has
*> abs(real part) + abs(imag. part) = 1.
*> Not referenced if JOBVR = 'N'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the matrix VR. LDVR >= 1, and
*> 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 (8*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> =1,...,N:
*> The QZ iteration failed. No eigenvectors have been
*> calculated, but ALPHA(j) and BETA(j) should be
*> correct for j=INFO+1,...,N.
*> > N: =N+1: other then QZ iteration failed in ZHGEQZ,
*> =N+2: error return from ZTGEVC.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ggev
*
* =====================================================================
SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
$ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
CHARACTER CHTEMP
INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
$ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR,
$ LWKMIN, LWKOPT
DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
$ SMLNUM, TEMP
COMPLEX*16 X
* ..
* .. Local Arrays ..
LOGICAL LDUMMA( 1 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
$ ZHGEQZ,
$ ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, ZUNMQR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1
* ..
* .. Statement Function definitions ..
ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
* ..
* .. Executable Statements ..
*
* Decode the input arguments
*
IF( LSAME( JOBVL, 'N' ) ) THEN
IJOBVL = 1
ILVL = .FALSE.
ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
IJOBVL = 2
ILVL = .TRUE.
ELSE
IJOBVL = -1
ILVL = .FALSE.
END IF
*
IF( LSAME( JOBVR, 'N' ) ) THEN
IJOBVR = 1
ILVR = .FALSE.
ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
IJOBVR = 2
ILVR = .TRUE.
ELSE
IJOBVR = -1
ILVR = .FALSE.
END IF
ILV = ILVL .OR. ILVR
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( IJOBVL.LE.0 ) THEN
INFO = -1
ELSE IF( IJOBVR.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
INFO = -11
ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
INFO = -13
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. The workspace is
* computed assuming ILO = 1 and IHI = N, the worst case.)
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 2*N )
LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N,
$ 0 ) )
LWKOPT = MAX( LWKOPT, N +
$ N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, 0 ) )
IF( ILVL ) THEN
LWKOPT = MAX( LWKOPT, N +
$ N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -15
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGGEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
ILASCL = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ANRMTO = SMLNUM
ILASCL = .TRUE.
ELSE IF( ANRM.GT.BIGNUM ) THEN
ANRMTO = BIGNUM
ILASCL = .TRUE.
END IF
IF( ILASCL )
$ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
* Scale B if max element outside range [SMLNUM,BIGNUM]
*
BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
ILBSCL = .FALSE.
IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
BNRMTO = SMLNUM
ILBSCL = .TRUE.
ELSE IF( BNRM.GT.BIGNUM ) THEN
BNRMTO = BIGNUM
ILBSCL = .TRUE.
END IF
IF( ILBSCL )
$ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
* Permute the matrices A, B to isolate eigenvalues if possible
* (Real Workspace: need 6*N)
*
ILEFT = 1
IRIGHT = N + 1
IRWRK = IRIGHT + N
CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
*
* Reduce B to triangular form (QR decomposition of B)
* (Complex Workspace: need N, prefer N*NB)
*
IROWS = IHI + 1 - ILO
IF( ILV ) THEN
ICOLS = N + 1 - ILO
ELSE
ICOLS = IROWS
END IF
ITAU = 1
IWRK = ITAU + IROWS
CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
$ WORK( IWRK ), LWORK+1-IWRK, IERR )
*
* Apply the orthogonal transformation to matrix A
* (Complex Workspace: need N, prefer N*NB)
*
CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
$ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
$ LWORK+1-IWRK, IERR )
*
* Initialize VL
* (Complex Workspace: need N, prefer N*NB)
*
IF( ILVL ) THEN
CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
IF( IROWS.GT.1 ) THEN
CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
$ VL( ILO+1, ILO ), LDVL )
END IF
CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
$ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
END IF
*
* Initialize VR
*
IF( ILVR )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
*
* Reduce to generalized Hessenberg form
*
IF( ILV ) THEN
*
* Eigenvectors requested -- work on whole matrix.
*
CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
$ LDVL, VR, LDVR, IERR )
ELSE
CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
$ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
END IF
*
* Perform QZ algorithm (Compute eigenvalues, and optionally, the
* Schur form and Schur vectors)
* (Complex Workspace: need N)
* (Real Workspace: need N)
*
IWRK = ITAU
IF( ILV ) THEN
CHTEMP = 'S'
ELSE
CHTEMP = 'E'
END IF
CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
$ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
$ LWORK+1-IWRK, RWORK( IRWRK ), IERR )
IF( IERR.NE.0 ) THEN
IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
INFO = IERR
ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
INFO = IERR - N
ELSE
INFO = N + 1
END IF
GO TO 70
END IF
*
* Compute Eigenvectors
* (Real Workspace: need 2*N)
* (Complex Workspace: need 2*N)
*
IF( ILV ) THEN
IF( ILVL ) THEN
IF( ILVR ) THEN
CHTEMP = 'B'
ELSE
CHTEMP = 'L'
END IF
ELSE
CHTEMP = 'R'
END IF
*
CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
$ LDVL,
$ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ),
$ IERR )
IF( IERR.NE.0 ) THEN
INFO = N + 2
GO TO 70
END IF
*
* Undo balancing on VL and VR and normalization
* (Workspace: none needed)
*
IF( ILVL ) THEN
CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), N, VL, LDVL, IERR )
DO 30 JC = 1, N
TEMP = ZERO
DO 10 JR = 1, N
TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
10 CONTINUE
IF( TEMP.LT.SMLNUM )
$ GO TO 30
TEMP = ONE / TEMP
DO 20 JR = 1, N
VL( JR, JC ) = VL( JR, JC )*TEMP
20 CONTINUE
30 CONTINUE
END IF
IF( ILVR ) THEN
CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
$ RWORK( IRIGHT ), N, VR, LDVR, IERR )
DO 60 JC = 1, N
TEMP = ZERO
DO 40 JR = 1, N
TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
40 CONTINUE
IF( TEMP.LT.SMLNUM )
$ GO TO 60
TEMP = ONE / TEMP
DO 50 JR = 1, N
VR( JR, JC ) = VR( JR, JC )*TEMP
50 CONTINUE
60 CONTINUE
END IF
END IF
*
* Undo scaling if necessary
*
70 CONTINUE
*
IF( ILASCL )
$ CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
*
IF( ILBSCL )
$ CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZGGEV
*
END
*> \brief \b ZGGHRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGHRD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgghrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgghrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgghrd.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
* LDQ, Z, LDZ, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ, COMPZ
* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
*> Hessenberg form using unitary transformations, where A is a
*> general matrix and B is upper triangular. The form of the
*> generalized eigenvalue problem is
*> A*x = lambda*B*x,
*> and B is typically made upper triangular by computing its QR
*> factorization and moving the unitary matrix Q to the left side
*> of the equation.
*>
*> This subroutine simultaneously reduces A to a Hessenberg matrix H:
*> Q**H*A*Z = H
*> and transforms B to another upper triangular matrix T:
*> Q**H*B*Z = T
*> in order to reduce the problem to its standard form
*> H*y = lambda*T*y
*> where y = Z**H*x.
*>
*> The unitary matrices Q and Z are determined as products of Givens
*> rotations. They may either be formed explicitly, or they may be
*> postmultiplied into input matrices Q1 and Z1, so that
*> Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
*> Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
*> If Q1 is the unitary matrix from the QR factorization of B in the
*> original equation A*x = lambda*B*x, then ZGGHRD reduces the original
*> problem to generalized Hessenberg form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'N': do not compute Q;
*> = 'I': Q is initialized to the unit matrix, and the
*> unitary matrix Q is returned;
*> = 'V': Q must contain a unitary matrix Q1 on entry,
*> and the product Q1*Q is returned.
*> \endverbatim
*>
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': do not compute Z;
*> = 'I': Z is initialized to the unit matrix, and the
*> unitary matrix Z is returned;
*> = 'V': Z must contain a unitary matrix Z1 on entry,
*> and the product Z1*Z is returned.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> ILO and IHI mark the rows and columns of A which are to be
*> reduced. 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 ZGGBAL; otherwise they
*> should be set to 1 and N respectively.
*> 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
*> rest is set to zero.
*> \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, N)
*> On entry, the N-by-N upper triangular matrix B.
*> On exit, the upper triangular matrix T = Q**H B Z. The
*> elements below the diagonal are set to zero.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ, N)
*> On entry, if COMPQ = 'V', the unitary matrix Q1, typically
*> from the QR factorization of B.
*> On exit, if COMPQ='I', the unitary matrix Q, and if
*> COMPQ = 'V', the product Q1*Q.
*> Not referenced if COMPQ='N'.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q.
*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> On entry, if COMPZ = 'V', the unitary matrix Z1.
*> On exit, if COMPZ='I', the unitary matrix Z, and if
*> COMPZ = 'V', the product Z1*Z.
*> Not referenced if COMPZ='N'.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z.
*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
*> \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.
*
*> \ingroup gghrd
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> This routine reduces A to Hessenberg and B to triangular form by
*> an unblocked reduction, as described in _Matrix_Computations_,
*> by Golub and van Loan (Johns Hopkins Press).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
$ Q,
$ LDQ, Z, LDZ, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ
INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CONE, CZERO
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
$ CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL ILQ, ILZ
INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
DOUBLE PRECISION C
COMPLEX*16 CTEMP, S
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Decode COMPQ
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ICOMPQ = 0
END IF
*
* Decode COMPZ
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ICOMPZ = 0
END IF
*
* Test the input parameters.
*
INFO = 0
IF( ICOMPQ.LE.0 ) THEN
INFO = -1
ELSE IF( ICOMPZ.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 ) THEN
INFO = -4
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
INFO = -11
ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGGHRD', -INFO )
RETURN
END IF
*
* Initialize Q and Z if desired.
*
IF( ICOMPQ.EQ.3 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
* Zero out lower triangle of B
*
DO 20 JCOL = 1, N - 1
DO 10 JROW = JCOL + 1, N
B( JROW, JCOL ) = CZERO
10 CONTINUE
20 CONTINUE
*
* Reduce A and B
*
DO 40 JCOL = ILO, IHI - 2
*
DO 30 JROW = IHI, JCOL + 2, -1
*
* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
*
CTEMP = A( JROW-1, JCOL )
CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S,
$ A( JROW-1, JCOL ) )
A( JROW, JCOL ) = CZERO
CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
$ A( JROW, JCOL+1 ), LDA, C, S )
CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
$ B( JROW, JROW-1 ), LDB, C, S )
IF( ILQ )
$ CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
$ DCONJG( S ) )
*
* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
*
CTEMP = B( JROW, JROW )
CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S,
$ B( JROW, JROW ) )
B( JROW, JROW-1 ) = CZERO
CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C,
$ S )
CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
$ S )
IF( ILZ )
$ CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C,
$ S )
30 CONTINUE
40 CONTINUE
*
RETURN
*
* End of ZGGHRD
*
END
*> \brief \b ZGTCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgtcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgtcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgtcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER INFO, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTCON estimates the reciprocal of the condition number of a complex
*> tridiagonal matrix A using the LU factorization as computed by
*> ZGTTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * 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] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) multipliers that define the matrix L from the
*> LU factorization of A as computed by ZGTTRF.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The n diagonal elements of the upper triangular matrix U from
*> the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) elements of the first superdiagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> The (n-2) elements of the second superdiagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= n, row i of the matrix was
*> interchanged with row IPIV(i). IPIV(i) will always be either
*> i or i+1; IPIV(i) = i indicates a row interchange was not
*> required.
*> \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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*
*> \ingroup gtcon
*
* =====================================================================
SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
INTEGER I, KASE, KASE1
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGTTRS, ZLACN2
* ..
* .. Intrinsic Functions ..
INTRINSIC DCMPLX
* ..
* .. Executable Statements ..
*
* Test the input arguments.
*
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( ANORM.LT.ZERO ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGTCON', -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
*
* Check that D(1:N) is non-zero.
*
DO 10 I = 1, N
IF( D( I ).EQ.DCMPLX( ZERO ) )
$ RETURN
10 CONTINUE
*
AINVNM = ZERO
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
20 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(U)*inv(L).
*
CALL ZGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
$ WORK, N, INFO )
ELSE
*
* Multiply by inv(L**H)*inv(U**H).
*
CALL ZGTTRS( 'Conjugate transpose', N, 1, DL, D, DU, DU2,
$ IPIV, WORK, N, INFO )
END IF
GO TO 20
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of ZGTCON
*
END
*> \brief \b ZGTRFS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTRFS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgtrfs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgtrfs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgtrfs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
* COMPLEX*16 B( LDB, * ), D( * ), DF( * ), DL( * ),
* $ DLF( * ), DU( * ), DU2( * ), DUF( * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTRFS improves the computed solution to a system of linear
*> equations when the coefficient matrix is tridiagonal, and provides
*> error bounds and backward error estimates for the solution.
*> \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] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) subdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) superdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] DLF
*> \verbatim
*> DLF is COMPLEX*16 array, dimension (N-1)
*> The (n-1) multipliers that define the matrix L from the
*> LU factorization of A as computed by ZGTTRF.
*> \endverbatim
*>
*> \param[in] DF
*> \verbatim
*> DF is COMPLEX*16 array, dimension (N)
*> The n diagonal elements of the upper triangular matrix U from
*> the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DUF
*> \verbatim
*> DUF is COMPLEX*16 array, dimension (N-1)
*> The (n-1) elements of the first superdiagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> The (n-2) elements of the second superdiagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= n, row i of the matrix was
*> interchanged with row IPIV(i). IPIV(i) will always be either
*> i or i+1; IPIV(i) = i indicates a row interchange was not
*> required.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> On entry, the solution matrix X, as computed by ZGTTRS.
*> On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gtrfs
*
* =====================================================================
SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
$ DU2,
$ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
COMPLEX*16 B( LDB, * ), D( * ), DF( * ), DL( * ),
$ DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
CHARACTER TRANSN, TRANST
INTEGER COUNT, I, J, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZCOPY, ZGTTRS, ZLACN2,
$ ZLAGTM
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. 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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -13
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -15
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGTRFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
IF( NOTRAN ) THEN
TRANSN = 'N'
TRANST = 'C'
ELSE
TRANSN = 'C'
TRANST = 'N'
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = 4
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 110 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - op(A) * X,
* where op(A) = A, A**T, or A**H, depending on TRANS.
*
CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
CALL ZLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX,
$ ONE,
$ WORK, N )
*
* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
* error bound.
*
IF( NOTRAN ) THEN
IF( N.EQ.1 ) THEN
RWORK( 1 ) = CABS1( B( 1, J ) ) +
$ CABS1( D( 1 ) )*CABS1( X( 1, J ) )
ELSE
RWORK( 1 ) = CABS1( B( 1, J ) ) +
$ CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
$ CABS1( DU( 1 ) )*CABS1( X( 2, J ) )
DO 30 I = 2, N - 1
RWORK( I ) = CABS1( B( I, J ) ) +
$ CABS1( DL( I-1 ) )*CABS1( X( I-1, J ) ) +
$ CABS1( D( I ) )*CABS1( X( I, J ) ) +
$ CABS1( DU( I ) )*CABS1( X( I+1, J ) )
30 CONTINUE
RWORK( N ) = CABS1( B( N, J ) ) +
$ CABS1( DL( N-1 ) )*CABS1( X( N-1, J ) ) +
$ CABS1( D( N ) )*CABS1( X( N, J ) )
END IF
ELSE
IF( N.EQ.1 ) THEN
RWORK( 1 ) = CABS1( B( 1, J ) ) +
$ CABS1( D( 1 ) )*CABS1( X( 1, J ) )
ELSE
RWORK( 1 ) = CABS1( B( 1, J ) ) +
$ CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
$ CABS1( DL( 1 ) )*CABS1( X( 2, J ) )
DO 40 I = 2, N - 1
RWORK( I ) = CABS1( B( I, J ) ) +
$ CABS1( DU( I-1 ) )*CABS1( X( I-1, J ) ) +
$ CABS1( D( I ) )*CABS1( X( I, J ) ) +
$ CABS1( DL( I ) )*CABS1( X( I+1, J ) )
40 CONTINUE
RWORK( N ) = CABS1( B( N, J ) ) +
$ CABS1( DU( N-1 ) )*CABS1( X( N-1, J ) ) +
$ CABS1( D( N ) )*CABS1( X( N, J ) )
END IF
END IF
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
S = ZERO
DO 50 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
ELSE
S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
$ ( RWORK( I )+SAFE1 ) )
END IF
50 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL ZGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
$ N,
$ INFO )
CALL ZAXPY( N, DCMPLX( ONE ), WORK, 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(op(A)))*
* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(op(A)) is the inverse of op(A)
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
* Use ZLACN2 to estimate the infinity-norm of the matrix
* inv(op(A)) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
DO 60 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
ELSE
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
$ SAFE1
END IF
60 CONTINUE
*
KASE = 0
70 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(op(A)**H).
*
CALL ZGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK,
$ N, INFO )
DO 80 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
80 CONTINUE
ELSE
*
* Multiply by inv(op(A))*diag(W).
*
DO 90 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
90 CONTINUE
CALL ZGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
$ WORK,
$ N, INFO )
END IF
GO TO 70
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 100 I = 1, N
LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
100 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
110 CONTINUE
*
RETURN
*
* End of ZGTRFS
*
END
*> \brief <b> ZGTSV computes the solution to system of linear equations A * X = B for GT matrices </b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTSV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgtsv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgtsv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgtsv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTSV solves the equation
*>
*> A*X = B,
*>
*> where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
*> partial pivoting.
*>
*> Note that the equation A**T *X = B may be solved by interchanging the
*> order of the arguments DU and DL.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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,out] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> On entry, DL must contain the (n-1) subdiagonal elements of
*> A.
*> On exit, DL is overwritten by the (n-2) elements of the
*> second superdiagonal of the upper triangular matrix U from
*> the LU factorization of A, in DL(1), ..., DL(n-2).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> On entry, D must contain the diagonal elements of A.
*> On exit, D is overwritten by the n diagonal elements of U.
*> \endverbatim
*>
*> \param[in,out] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> On entry, DU must contain the (n-1) superdiagonal elements
*> of A.
*> On exit, DU is overwritten by the (n-1) elements of the first
*> superdiagonal of U.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS 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, and the solution
*> has not been computed. The factorization has not been
*> completed unless i = N.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gtsv
*
* =====================================================================
SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER J, K
COMPLEX*16 MULT, TEMP, ZDUM
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGTSV ', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
DO 30 K = 1, N - 1
IF( DL( K ).EQ.ZERO ) THEN
*
* Subdiagonal is zero, no elimination is required.
*
IF( D( K ).EQ.ZERO ) THEN
*
* Diagonal is zero: set INFO = K and return; a unique
* solution can not be found.
*
INFO = K
RETURN
END IF
ELSE IF( CABS1( D( K ) ).GE.CABS1( DL( K ) ) ) THEN
*
* No row interchange required
*
MULT = DL( K ) / D( K )
D( K+1 ) = D( K+1 ) - MULT*DU( K )
DO 10 J = 1, NRHS
B( K+1, J ) = B( K+1, J ) - MULT*B( K, J )
10 CONTINUE
IF( K.LT.( N-1 ) )
$ DL( K ) = ZERO
ELSE
*
* Interchange rows K and K+1
*
MULT = D( K ) / DL( K )
D( K ) = DL( K )
TEMP = D( K+1 )
D( K+1 ) = DU( K ) - MULT*TEMP
IF( K.LT.( N-1 ) ) THEN
DL( K ) = DU( K+1 )
DU( K+1 ) = -MULT*DL( K )
END IF
DU( K ) = TEMP
DO 20 J = 1, NRHS
TEMP = B( K, J )
B( K, J ) = B( K+1, J )
B( K+1, J ) = TEMP - MULT*B( K+1, J )
20 CONTINUE
END IF
30 CONTINUE
IF( D( N ).EQ.ZERO ) THEN
INFO = N
RETURN
END IF
*
* Back solve with the matrix U from the factorization.
*
DO 50 J = 1, NRHS
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
DO 40 K = N - 2, 1, -1
B( K, J ) = ( B( K, J )-DU( K )*B( K+1, J )-DL( K )*
$ B( K+2, J ) ) / D( K )
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of ZGTSV
*
END
*> \brief <b> ZGTSVX computes the solution to system of linear equations A * X = B for GT matrices </b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTSVX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgtsvx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgtsvx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgtsvx.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
* DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
* WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER FACT, TRANS
* INTEGER INFO, LDB, LDX, N, NRHS
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
* COMPLEX*16 B( LDB, * ), D( * ), DF( * ), DL( * ),
* $ DLF( * ), DU( * ), DU2( * ), DUF( * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTSVX uses the LU factorization to compute the solution to a complex
*> system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
*> where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
*> matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
* =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
*> as A = L * U, where L is a product of permutation and unit lower
*> bidiagonal matrices and U is upper triangular with nonzeros in
*> only the main diagonal and first two superdiagonals.
*>
*> 2. If some U(i,i)=0, so that U is exactly singular, then the routine
*> returns with INFO = i. Otherwise, the factored form of A is used
*> to estimate the condition number of the matrix A. If the
*> reciprocal of the condition number is less than machine precision,
*> INFO = N+1 is returned as a warning, but the routine still goes on
*> to solve for X and compute error bounds as described below.
*>
*> 3. The system of equations is solved for X using the factored form
*> of A.
*>
*> 4. Iterative refinement is applied to improve the computed solution
*> matrix and calculate error bounds and backward error estimates
*> for it.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] FACT
*> \verbatim
*> FACT is CHARACTER*1
*> Specifies whether or not the factored form of A has been
*> supplied on entry.
*> = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form
*> of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
*> be modified.
*> = 'N': The matrix will be copied to DLF, DF, and DUF
*> and factored.
*> \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] 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] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) subdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The n diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) superdiagonal elements of A.
*> \endverbatim
*>
*> \param[in,out] DLF
*> \verbatim
*> DLF is COMPLEX*16 array, dimension (N-1)
*> If FACT = 'F', then DLF is an input argument and on entry
*> contains the (n-1) multipliers that define the matrix L from
*> the LU factorization of A as computed by ZGTTRF.
*>
*> If FACT = 'N', then DLF is an output argument and on exit
*> contains the (n-1) multipliers that define the matrix L from
*> the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] DF
*> \verbatim
*> DF is COMPLEX*16 array, dimension (N)
*> If FACT = 'F', then DF is an input argument and on entry
*> contains the n diagonal elements of the upper triangular
*> matrix U from the LU factorization of A.
*>
*> If FACT = 'N', then DF is an output argument and on exit
*> contains the n diagonal elements of the upper triangular
*> matrix U from the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] DUF
*> \verbatim
*> DUF is COMPLEX*16 array, dimension (N-1)
*> If FACT = 'F', then DUF is an input argument and on entry
*> contains the (n-1) elements of the first superdiagonal of U.
*>
*> If FACT = 'N', then DUF is an output argument and on exit
*> contains the (n-1) elements of the first superdiagonal of U.
*> \endverbatim
*>
*> \param[in,out] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> If FACT = 'F', then DU2 is an input argument and on entry
*> contains the (n-2) elements of the second superdiagonal of
*> U.
*>
*> If FACT = 'N', then DU2 is an output argument and on exit
*> contains the (n-2) elements of the second superdiagonal of
*> U.
*> \endverbatim
*>
*> \param[in,out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> If FACT = 'F', then IPIV is an input argument and on entry
*> contains the pivot indices from the LU factorization of A as
*> computed by ZGTTRF.
*>
*> If FACT = 'N', then IPIV is an output argument and on exit
*> contains the pivot indices from the LU factorization of A;
*> row i of the matrix was interchanged with row IPIV(i).
*> IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
*> a row interchange was not required.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> The N-by-NRHS right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The estimate of the reciprocal condition number of the matrix
*> A. If RCOND is less than the machine precision (in
*> particular, if RCOND = 0), the matrix is singular to working
*> precision. This condition is indicated by a return code of
*> INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*> > 0: if INFO = i, and i is
*> <= N: U(i,i) is exactly zero. The factorization
*> has not been completed unless i = N, but the
*> factor U is exactly singular, so the solution
*> and error bounds could not be computed.
*> RCOND = 0 is returned.
*> = N+1: U is nonsingular, but RCOND is less than machine
*> precision, meaning that the matrix is singular
*> to working precision. Nevertheless, the
*> solution and error bounds are computed because
*> there are a number of situations where the
*> computed solution can be more accurate than the
*> value of RCOND would suggest.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gtsvx
*
* =====================================================================
SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF,
$ DUF,
$ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
$ WORK, RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER FACT, TRANS
INTEGER INFO, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
COMPLEX*16 B( LDB, * ), D( * ), DF( * ), DL( * ),
$ DLF( * ), DU( * ), DU2( * ), DUF( * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOFACT, NOTRAN
CHARACTER NORM
DOUBLE PRECISION ANORM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANGT
EXTERNAL LSAME, DLAMCH, ZLANGT
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZGTCON, ZGTRFS, ZGTTRF,
$ ZGTTRS,
$ ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGTSVX', -INFO )
RETURN
END IF
*
IF( NOFACT ) THEN
*
* Compute the LU factorization of A.
*
CALL ZCOPY( N, D, 1, DF, 1 )
IF( N.GT.1 ) THEN
CALL ZCOPY( N-1, DL, 1, DLF, 1 )
CALL ZCOPY( N-1, DU, 1, DUF, 1 )
END IF
CALL ZGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
IF( NOTRAN ) THEN
NORM = '1'
ELSE
NORM = 'I'
END IF
ANORM = ZLANGT( NORM, N, DL, D, DU )
*
* Compute the reciprocal of the condition number of A.
*
CALL ZGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND,
$ WORK,
$ INFO )
*
* Compute the solution vectors X.
*
CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL ZGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
$ INFO )
*
* Use iterative refinement to improve the computed solutions and
* compute error bounds and backward error estimates for them.
*
CALL ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
$ IPIV,
$ B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of ZGTSVX
*
END
*> \brief \b ZGTTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgttrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgttrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgttrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTTRF computes an LU factorization of a complex tridiagonal matrix A
*> using elimination with partial pivoting and row interchanges.
*>
*> The factorization has the form
*> A = L * U
*> where L is a product of permutation and unit lower bidiagonal
*> matrices and U is upper triangular with nonzeros in only the main
*> diagonal and first two superdiagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in,out] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> On entry, DL must contain the (n-1) sub-diagonal elements of
*> A.
*>
*> On exit, DL is overwritten by the (n-1) multipliers that
*> define the matrix L from the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> On entry, D must contain the diagonal elements of A.
*>
*> On exit, D is overwritten by the n diagonal elements of the
*> upper triangular matrix U from the LU factorization of A.
*> \endverbatim
*>
*> \param[in,out] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> On entry, DU must contain the (n-1) super-diagonal elements
*> of A.
*>
*> On exit, DU is overwritten by the (n-1) elements of the first
*> super-diagonal of U.
*> \endverbatim
*>
*> \param[out] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> On exit, DU2 is overwritten by the (n-2) elements of the
*> second super-diagonal of U.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= n, row i of the matrix was
*> interchanged with row IPIV(i). IPIV(i) will always be either
*> i or i+1; IPIV(i) = i indicates a row interchange was not
*> required.
*> \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.
*
*> \ingroup gttrf
*
* =====================================================================
SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 FACT, TEMP, ZDUM
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'ZGTTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize IPIV(i) = i and DU2(i) = 0
*
DO 10 I = 1, N
IPIV( I ) = I
10 CONTINUE
DO 20 I = 1, N - 2
DU2( I ) = ZERO
20 CONTINUE
*
DO 30 I = 1, N - 2
IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
*
* No row interchange required, eliminate DL(I)
*
IF( CABS1( D( I ) ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
*
* Interchange rows I and I+1, eliminate DL(I)
*
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
DU2( I ) = DU( I+1 )
DU( I+1 ) = -FACT*DU( I+1 )
IPIV( I ) = I + 1
END IF
30 CONTINUE
IF( N.GT.1 ) THEN
I = N - 1
IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
IF( CABS1( D( I ) ).NE.ZERO ) THEN
FACT = DL( I ) / D( I )
DL( I ) = FACT
D( I+1 ) = D( I+1 ) - FACT*DU( I )
END IF
ELSE
FACT = D( I ) / DL( I )
D( I ) = DL( I )
DL( I ) = FACT
TEMP = DU( I )
DU( I ) = D( I+1 )
D( I+1 ) = TEMP - FACT*D( I+1 )
IPIV( I ) = I + 1
END IF
END IF
*
* Check for a zero on the diagonal of U.
*
DO 40 I = 1, N
IF( CABS1( D( I ) ).EQ.ZERO ) THEN
INFO = I
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
RETURN
*
* End of ZGTTRF
*
END
*> \brief \b ZGTTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgttrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgttrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgttrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTTRS solves one of the systems of equations
*> A * X = B, A**T * X = B, or A**H * X = B,
*> with a tridiagonal matrix A using the LU factorization computed
*> by ZGTTRF.
*> \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.
*> \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] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) multipliers that define the matrix L from the
*> LU factorization of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The n diagonal elements of the upper triangular matrix U from
*> the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) elements of the first super-diagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> The (n-2) elements of the second super-diagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= n, row i of the matrix was
*> interchanged with row IPIV(i). IPIV(i) will always be either
*> i or i+1; IPIV(i) = i indicates a row interchange was not
*> required.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the matrix of right hand side vectors B.
*> On exit, B is overwritten by the solution vectors 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 = -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.
*
*> \ingroup gttrs
*
* =====================================================================
SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B,
$ LDB,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER ITRANS, J, JB, NB
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGTTS2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
$ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGTTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
* Decode TRANS
*
IF( NOTRAN ) THEN
ITRANS = 0
ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN
ITRANS = 1
ELSE
ITRANS = 2
END IF
*
* Determine the number of right-hand sides to solve at a time.
*
IF( NRHS.EQ.1 ) THEN
NB = 1
ELSE
NB = MAX( 1, ILAENV( 1, 'ZGTTRS', TRANS, N, NRHS, -1, -1 ) )
END IF
*
IF( NB.GE.NRHS ) THEN
CALL ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
ELSE
DO 10 J = 1, NRHS, NB
JB = MIN( NRHS-J+1, NB )
CALL ZGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1,
$ J ),
$ LDB )
10 CONTINUE
END IF
*
* End of ZGTTRS
*
END
*> \brief \b ZGTTS2 solves a system of linear equations with a tridiagonal matrix using the LU factorization computed by sgttrf.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTTS2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgtts2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgtts2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgtts2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
*
* .. Scalar Arguments ..
* INTEGER ITRANS, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGTTS2 solves one of the systems of equations
*> A * X = B, A**T * X = B, or A**H * X = B,
*> with a tridiagonal matrix A using the LU factorization computed
*> by ZGTTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITRANS
*> \verbatim
*> ITRANS is INTEGER
*> Specifies the form of the system of equations.
*> = 0: A * X = B (No transpose)
*> = 1: A**T * X = B (Transpose)
*> = 2: A**H * X = B (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \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] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) multipliers that define the matrix L from the
*> LU factorization of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The n diagonal elements of the upper triangular matrix U from
*> the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) elements of the first super-diagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*> DU2 is COMPLEX*16 array, dimension (N-2)
*> The (n-2) elements of the second super-diagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices; for 1 <= i <= n, row i of the matrix was
*> interchanged with row IPIV(i). IPIV(i) will always be either
*> i or i+1; IPIV(i) = i indicates a row interchange was not
*> required.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the matrix of right hand side vectors B.
*> On exit, B is overwritten by the solution vectors X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gtts2
*
* =====================================================================
SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B,
$ LDB )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER ITRANS, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
COMPLEX*16 TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( ITRANS.EQ.0 ) THEN
*
* Solve A*X = B using the LU factorization of A,
* overwriting each right hand side vector with its solution.
*
IF( NRHS.LE.1 ) THEN
J = 1
10 CONTINUE
*
* Solve L*x = b.
*
DO 20 I = 1, N - 1
IF( IPIV( I ).EQ.I ) THEN
B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
ELSE
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - DL( I )*B( I, J )
END IF
20 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 30 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
30 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 10
END IF
ELSE
DO 60 J = 1, NRHS
*
* Solve L*x = b.
*
DO 40 I = 1, N - 1
IF( IPIV( I ).EQ.I ) THEN
B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
ELSE
TEMP = B( I, J )
B( I, J ) = B( I+1, J )
B( I+1, J ) = TEMP - DL( I )*B( I, J )
END IF
40 CONTINUE
*
* Solve U*x = b.
*
B( N, J ) = B( N, J ) / D( N )
IF( N.GT.1 )
$ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
$ D( N-1 )
DO 50 I = N - 2, 1, -1
B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
$ B( I+2, J ) ) / D( I )
50 CONTINUE
60 CONTINUE
END IF
ELSE IF( ITRANS.EQ.1 ) THEN
*
* Solve A**T * X = B.
*
IF( NRHS.LE.1 ) THEN
J = 1
70 CONTINUE
*
* Solve U**T * x = b.
*
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 80 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
$ B( I-2, J ) ) / D( I )
80 CONTINUE
*
* Solve L**T * x = b.
*
DO 90 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DL( I )*TEMP
B( I, J ) = TEMP
END IF
90 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 70
END IF
ELSE
DO 120 J = 1, NRHS
*
* Solve U**T * x = b.
*
B( 1, J ) = B( 1, J ) / D( 1 )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
DO 100 I = 3, N
B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
$ DU2( I-2 )*B( I-2, J ) ) / D( I )
100 CONTINUE
*
* Solve L**T * x = b.
*
DO 110 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DL( I )*TEMP
B( I, J ) = TEMP
END IF
110 CONTINUE
120 CONTINUE
END IF
ELSE
*
* Solve A**H * X = B.
*
IF( NRHS.LE.1 ) THEN
J = 1
130 CONTINUE
*
* Solve U**H * x = b.
*
B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) /
$ DCONJG( D( 2 ) )
DO 140 I = 3, N
B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )-
$ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) /
$ DCONJG( D( I ) )
140 CONTINUE
*
* Solve L**H * x = b.
*
DO 150 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP
B( I, J ) = TEMP
END IF
150 CONTINUE
IF( J.LT.NRHS ) THEN
J = J + 1
GO TO 130
END IF
ELSE
DO 180 J = 1, NRHS
*
* Solve U**H * x = b.
*
B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) )
IF( N.GT.1 )
$ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) )
$ / DCONJG( D( 2 ) )
DO 160 I = 3, N
B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*
$ B( I-1, J )-DCONJG( DU2( I-2 ) )*
$ B( I-2, J ) ) / DCONJG( D( I ) )
160 CONTINUE
*
* Solve L**H * x = b.
*
DO 170 I = N - 1, 1, -1
IF( IPIV( I ).EQ.I ) THEN
B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*
$ B( I+1, J )
ELSE
TEMP = B( I+1, J )
B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP
B( I, J ) = TEMP
END IF
170 CONTINUE
180 CONTINUE
END IF
END IF
*
* End of ZGTTS2
*
END
*> \brief \b ZHECON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHECON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhecon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhecon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhecon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHECON estimates the reciprocal of the condition number of a complex
*> Hermitian matrix A using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by ZHETRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \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 block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZHETRF.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZHETRF.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*
*> \ingroup hecon
*
* =====================================================================
SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHETRS, ZLACN2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHECON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
*
CALL ZHETRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of ZHECON
*
END
*> \brief <b> ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEEV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zheev.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zheev.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zheev.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup heev
*
* =====================================================================
SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
$ INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ) = DBLE( 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> ZHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEEVD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zheevd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zheevd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zheevd.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
* LRWORK, IWORK, LIWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
*> complex Hermitian matrix A. If eigenvectors are desired, it uses a
*> divide and conquer algorithm.
*>
*> \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.
*> If N <= 1, LWORK must be at least 1.
*> If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal sizes of the WORK, RWORK and
*> IWORK arrays, returns these values as the first entries of
*> the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of the array RWORK.
*> If N <= 1, LRWORK must be at least 1.
*> If JOBZ = 'N' and N > 1, LRWORK must be at least N.
*> If JOBZ = 'V' and N > 1, LRWORK must be at least
*> 1 + 5*N + 2*N**2.
*>
*> If LRWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*> LIWORK is INTEGER
*> The dimension of the array IWORK.
*> If N <= 1, LIWORK must be at least 1.
*> If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
*> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
*>
*> If LIWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK 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
*> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
*> to converge; i off-diagonal elements of an intermediate
*> tridiagonal form did not converge to zero;
*> if INFO = i and JOBZ = 'V', then the algorithm failed
*> to compute an eigenvalue 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.
*
*> \ingroup heevd
*
*> \par Further Details:
* =====================
*>
*> Modified description of INFO. Sven, 16 Feb 05.
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*>
* =====================================================================
SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK,
$ RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
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, INDRWK, INDTAU, INDWK2,
$ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
$ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
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, ZLACPY,
$ ZLASCL,
$ ZSTEDC, ZUNMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.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
IF( N.LE.1 ) THEN
LWMIN = 1
LRWMIN = 1
LIWMIN = 1
LOPT = LWMIN
LROPT = LRWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LWMIN = 2*N + N*N
LRWMIN = 1 + 5*N + 2*N**2
LIWMIN = 3 + 5*N
ELSE
LWMIN = N + 1
LRWMIN = N
LIWMIN = 1
END IF
LOPT = MAX( LWMIN, N +
$ N*ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1,
$ -1 ) )
LROPT = LRWMIN
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
RWORK( 1 ) = REAL( LROPT )
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = DBLE( A( 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
INDRWK = INDE + N
INDWK2 = INDWRK + N*N
LLWORK = LWORK - INDWRK + 1
LLWRK2 = LWORK - INDWK2 + 1
LLRWK = LRWORK - INDRWK + 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
* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call ZUNMTR to multiply it to the
* Householder transformations represented as Householder vectors in
* A.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
$ IWORK, LIWORK, INFO )
CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
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
*
WORK( 1 ) = LOPT
RWORK( 1 ) = REAL( LROPT )
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of ZHEEVD
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetd2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetd2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetd2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup hetd2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ) = DBLE( 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 ) = DBLE( A( I+1, I+1 ) )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = DBLE( 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 ) = DBLE( 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 ) = DBLE( A( I, I ) )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = DBLE( A( N, N ) )
END IF
*
RETURN
*
* End of ZHETD2
*
END
*> \brief \b ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm, calling Level 2 BLAS).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETF2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetf2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETF2 computes the factorization of a complex Hermitian matrix A
*> using the Bunch-Kaufman diagonal pivoting method:
*>
*> A = U*D*U**H or A = L*D*L**H
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, U**H is the conjugate transpose of U, and D is
*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*>
*> 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, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \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)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \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, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hetf2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**H, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**H, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*> 09-29-06 - patch from
*> Bobby Cheng, MathWorks
*>
*> Replace l.210 and l.393
*> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*> by
*> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*>
*> 01-01-96 - Based on modifications by
*> J. Lewis, Boeing Computer Services Company
*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*
* =====================================================================
SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
$ TT
COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
INTEGER IZAMAX
DOUBLE PRECISION DLAPY2
EXTERNAL LSAME, IZAMAX, DLAPY2, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
* ..
* .. 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' )
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( 'ZHETF2', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**H using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 90
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, A( 1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR.
$ DISNAN(ABSAKK) ) THEN
*
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
*
* ============================================================
*
* Test for interchange
*
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
*
END IF
*
* ============================================================
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
DO 20 J = KP + 1, KK - 1
T = DCONJG( A( J, KK ) )
A( J, KK ) = DCONJG( A( KP, J ) )
A( KP, J ) = T
20 CONTINUE
A( KP, KK ) = DCONJG( A( KP, KK ) )
R1 = DBLE( A( KK, KK ) )
A( KK, KK ) = DBLE( A( KP, KP ) )
A( KP, KP ) = R1
IF( KSTEP.EQ.2 ) THEN
A( K, K ) = DBLE( A( K, K ) )
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
ELSE
A( K, K ) = DBLE( A( K, K ) )
IF( KSTEP.EQ.2 )
$ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) )
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)**H = A - W(k)*1/D(k)*W(k)**H
*
R1 = ONE / DBLE( A( K, K ) )
CALL ZHER( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**H
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H
*
IF( K.GT.2 ) THEN
*
D = DLAPY2( DBLE( A( K-1, K ) ),
$ DIMAG( A( K-1, K ) ) )
D22 = DBLE( A( K-1, K-1 ) ) / D
D11 = DBLE( A( K, K ) ) / D
TT = ONE / ( D11*D22-ONE )
D12 = A( K-1, K ) / D
D = TT / D
*
DO 40 J = K - 2, 1, -1
WKM1 = D*( D11*A( J, K-1 )-DCONJG( D12 )*
$ A( J, K ) )
WK = D*( D22*A( J, K )-D12*A( J, K-1 ) )
DO 30 I = J, 1, -1
A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) -
$ A( I, K-1 )*DCONJG( WKM1 )
30 CONTINUE
A( J, K ) = WK
A( J, K-1 ) = WKM1
A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 )
40 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**H using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
50 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 90
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( A( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR.
$ DISNAN(ABSAKK) ) THEN
*
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
*
* ============================================================
*
* Test for interchange
*
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
$ 1 )
ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
*
END IF
*
* ============================================================
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ),
$ 1 )
DO 60 J = KK + 1, KP - 1
T = DCONJG( A( J, KK ) )
A( J, KK ) = DCONJG( A( KP, J ) )
A( KP, J ) = T
60 CONTINUE
A( KP, KK ) = DCONJG( A( KP, KK ) )
R1 = DBLE( A( KK, KK ) )
A( KK, KK ) = DBLE( A( KP, KP ) )
A( KP, KP ) = R1
IF( KSTEP.EQ.2 ) THEN
A( K, K ) = DBLE( A( K, K ) )
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
ELSE
A( K, K ) = DBLE( A( K, K ) )
IF( KSTEP.EQ.2 )
$ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) )
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)**H = A - W(k)*(1/D(k))*W(k)**H
*
R1 = ONE / DBLE( A( K, K ) )
CALL ZHER( UPLO, N-K, -R1, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column K
*
CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k)
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**H
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D = DLAPY2( DBLE( A( K+1, K ) ),
$ DIMAG( A( K+1, K ) ) )
D11 = DBLE( A( K+1, K+1 ) ) / D
D22 = DBLE( A( K, K ) ) / D
TT = ONE / ( D11*D22-ONE )
D21 = A( K+1, K ) / D
D = TT / D
*
DO 80 J = K + 2, N
WK = D*( D11*A( J, K )-D21*A( J, K+1 ) )
WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )*
$ A( J, K ) )
DO 70 I = J, N
A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) -
$ A( I, K+1 )*DCONJG( WKP1 )
70 CONTINUE
A( J, K ) = WK
A( J, K+1 ) = WKP1
A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 )
80 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 50
*
END IF
*
90 CONTINUE
RETURN
*
* End of ZHETF2
*
END
*> \brief \b ZHETRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrd.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup hetrd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 = MAX( 1, 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 ) = DBLE( 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 ) = DBLE( 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 ZHETRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETRF computes the factorization of a complex Hermitian matrix A
*> using the Bunch-Kaufman diagonal pivoting method. The form of the
*> factorization is
*>
*> A = U*D*U**H or A = L*D*L**H
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is Hermitian and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the blocked 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, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \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)
*> Details of the interchanges and the block structure of D.
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \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 WORK. LWORK >= 1. For best performance
*> LWORK >= N*NB, where NB is the block size returned by ILAENV.
*> \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, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hetrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**H, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**H, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHETF2, ZLAHEF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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 = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'ZHETRF', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, N*NB )
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF', UPLO, N, -1, -1,
$ -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**H using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by ZLAHEF;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL ZLAHEF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N,
$ IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL ZHETF2( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**H using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by ZLAHEF;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL ZLAHEF( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
$ IPIV( K ),
$ WORK, N, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL ZHETF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
$ IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZHETRF
*
END
*> \brief \b ZHETRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETRI computes the inverse of a complex Hermitian indefinite matrix
*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by
*> ZHETRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \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 block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by ZHETRF.
*>
*> On exit, if INFO = 0, the (Hermitian) inverse of the original
*> matrix. If UPLO = 'U', the upper triangular part of the
*> inverse is formed and the part of A below the diagonal is not
*> referenced; if UPLO = 'L' the lower triangular part of the
*> inverse is formed and the part of A above the diagonal is
*> not referenced.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZHETRF.
*> \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
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hetri
*
* =====================================================================
SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
COMPLEX*16 CONE, ZERO
PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KP, KSTEP
DOUBLE PRECISION AK, AKP1, D, T
COMPLEX*16 AKKP1, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZHEMV, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, MAX
* ..
* .. 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( 'ZHETRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**H.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / DBLE( A( K, K ) )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1,
$ A( 1,
$ K ), 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K+1 ) )
AK = DBLE( A( K, K ) ) / T
AKP1 = DBLE( A( K+1, K+1 ) ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1,
$ A( 1,
$ K ), 1 ) )
A( K, K+1 ) = A( K, K+1 ) -
$ ZDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ),
$ 1 )
CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ DBLE( ZDOTC( K-1, WORK, 1, A( 1,
$ K+1 ),
$ 1 ) )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
DO 40 J = KP + 1, K - 1
TEMP = DCONJG( A( J, K ) )
A( J, K ) = DCONJG( A( KP, J ) )
A( KP, J ) = TEMP
40 CONTINUE
A( KP, K ) = DCONJG( A( KP, K ) )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
GO TO 30
50 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**H.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
60 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / DBLE( A( K, K ) )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA,
$ WORK,
$ 1, ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( A( K, K-1 ) )
AK = DBLE( A( K-1, K-1 ) ) / T
AKP1 = DBLE( A( K, K ) ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA,
$ WORK,
$ 1, ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1,
$ A( K+1, K ), 1 ) )
A( K, K-1 ) = A( K, K-1 ) -
$ ZDOTC( N-K, A( K+1, K ), 1, A( K+1,
$ K-1 ),
$ 1 )
CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA,
$ WORK,
$ 1, ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ DBLE( ZDOTC( N-K, WORK, 1, A( K+1,
$ K-1 ),
$ 1 ) )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
DO 70 J = K + 1, KP - 1
TEMP = DCONJG( A( J, K ) )
A( J, K ) = DCONJG( A( KP, J ) )
A( KP, J ) = TEMP
70 CONTINUE
A( KP, K ) = DCONJG( A( KP, K ) )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
GO TO 60
80 CONTINUE
END IF
*
RETURN
*
* End of ZHETRI
*
END
*> \brief \b ZHETRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETRS solves a system of linear equations A*X = B with a complex
*> Hermitian matrix A using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by ZHETRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \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 block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZHETRF.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZHETRF.
*> \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.
*
*> \ingroup hetrs
*
* =====================================================================
SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
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 UPPER
INTEGER J, K, KP
DOUBLE PRECISION S
COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV,
$ ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCONJG, MAX
* ..
* .. Executable Statements ..
*
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( 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( 'ZHETRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**H.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = DBLE( ONE ) / DBLE( A( K, K ) )
CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB,
$ B( 1, 1 ), LDB )
CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / DCONJG( AKM1K )
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / DCONJG( AKM1K )
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**H *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**H(K)), where U(K) is the transformation
* stored in column K of A.
*
IF( K.GT.1 ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.GT.1 ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
*
CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**H.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K,
$ 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = DBLE( ONE ) / DBLE( A( K, K ) )
CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K,
$ 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / DCONJG( AKM1K )
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / DCONJG( AKM1K )
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**H *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**H(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
$ B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
$ B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
*
CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
$ B( K-1, 1 ), LDB )
CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of ZHETRS
*
END
*> \brief \b ZHGEQZ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHGEQZ + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhgeqz.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhgeqz.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhgeqz.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
* ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
* RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ, COMPZ, JOB
* INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ),
* $ Q( LDQ, * ), T( LDT, * ), WORK( * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
*> where H is an upper Hessenberg matrix and T is upper triangular,
*> using the single-shift QZ method.
*> Matrix pairs of this type are produced by the reduction to
*> generalized upper Hessenberg form of a complex matrix pair (A,B):
*>
*> A = Q1*H*Z1**H, B = Q1*T*Z1**H,
*>
*> as computed by ZGGHRD.
*>
*> If JOB='S', then the Hessenberg-triangular pair (H,T) is
*> also reduced to generalized Schur form,
*>
*> H = Q*S*Z**H, T = Q*P*Z**H,
*>
*> where Q and Z are unitary matrices and S and P are upper triangular.
*>
*> Optionally, the unitary matrix Q from the generalized Schur
*> factorization may be postmultiplied into an input matrix Q1, and the
*> unitary matrix Z may be postmultiplied into an input matrix Z1.
*> If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced
*> the matrix pair (A,B) to generalized Hessenberg form, then the output
*> matrices Q1*Q and Z1*Z are the unitary factors from the generalized
*> Schur factorization of (A,B):
*>
*> A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.
*>
*> To avoid overflow, eigenvalues of the matrix pair (H,T)
*> (equivalently, of (A,B)) are computed as a pair of complex values
*> (alpha,beta). If beta is nonzero, lambda = alpha / beta is an
*> eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)
*> A*x = lambda*B*x
*> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
*> alternate form of the GNEP
*> mu*A*y = B*y.
*> The values of alpha and beta for the i-th eigenvalue can be read
*> directly from the generalized Schur form: alpha = S(i,i),
*> beta = P(i,i).
*>
*> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
*> Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
*> pp. 241--256.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> = 'E': Compute eigenvalues only;
*> = 'S': Computer eigenvalues and the Schur form.
*> \endverbatim
*>
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'N': Left Schur vectors (Q) are not computed;
*> = 'I': Q is initialized to the unit matrix and the matrix Q
*> of left Schur vectors of (H,T) is returned;
*> = 'V': Q must contain a unitary matrix Q1 on entry and
*> the product Q1*Q is returned.
*> \endverbatim
*>
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': Right Schur vectors (Z) are not computed;
*> = 'I': Q is initialized to the unit matrix and the matrix Z
*> of right Schur vectors of (H,T) is returned;
*> = 'V': Z must contain a unitary matrix Z1 on entry and
*> the product Z1*Z is returned.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices H, T, Q, and Z. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> ILO and IHI mark the rows and columns of H which are in
*> Hessenberg form. It is assumed that A is already upper
*> triangular in rows and columns 1:ILO-1 and IHI+1:N.
*> If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH, N)
*> On entry, the N-by-N upper Hessenberg matrix H.
*> On exit, if JOB = 'S', H contains the upper triangular
*> matrix S from the generalized Schur factorization.
*> If JOB = 'E', the diagonal of H matches that of S, but
*> the rest of H is unspecified.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max( 1, N ).
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT, N)
*> On entry, the N-by-N upper triangular matrix T.
*> On exit, if JOB = 'S', T contains the upper triangular
*> matrix P from the generalized Schur factorization.
*> If JOB = 'E', the diagonal of T matches that of P, but
*> the rest of T is unspecified.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16 array, dimension (N)
*> The complex scalars alpha that define the eigenvalues of
*> GNEP. ALPHA(i) = S(i,i) in the generalized Schur
*> factorization.
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*> BETA is COMPLEX*16 array, dimension (N)
*> The real non-negative scalars beta that define the
*> eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized
*> Schur factorization.
*>
*> Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
*> represent the j-th eigenvalue of the matrix pair (A,B), in
*> one of the forms lambda = alpha/beta or mu = beta/alpha.
*> Since either lambda or mu may overflow, they should not,
*> in general, be computed.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ, N)
*> On entry, if COMPQ = 'V', the unitary matrix Q1 used in the
*> reduction of (A,B) to generalized Hessenberg form.
*> On exit, if COMPQ = 'I', the unitary matrix of left Schur
*> vectors of (H,T), and if COMPQ = 'V', the unitary matrix of
*> left Schur vectors of (A,B).
*> Not referenced if COMPQ = 'N'.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1.
*> If COMPQ='V' or 'I', then LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
*> reduction of (A,B) to generalized Hessenberg form.
*> On exit, if COMPZ = 'I', the unitary matrix of right Schur
*> vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
*> right Schur vectors of (A,B).
*> Not referenced if COMPZ = 'N'.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1.
*> If COMPZ='V' or 'I', then LDZ >= 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,N).
*>
*> 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 (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> = 1,...,N: the QZ iteration did not converge. (H,T) is not
*> in Schur form, but ALPHA(i) and BETA(i),
*> i=INFO+1,...,N should be correct.
*> = N+1,...,2*N: the shift calculation failed. (H,T) is not
*> in Schur form, but ALPHA(i) and BETA(i),
*> i=INFO-N+1,...,N should be correct.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hgeqz
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> We assume that complex ABS works as long as its value is less than
*> overflow.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T,
$ LDT,
$ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
$ RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER COMPQ, COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ),
$ Q( LDQ, * ), T( LDT, * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
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 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY
INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
$ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
$ JR, MAXIT
DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
$ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
$ CTEMP3, ESHIFT, S, SHIFT, SIGNBC,
$ U12, X, ABI12, Y
* ..
* .. External Functions ..
COMPLEX*16 ZLADIV
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHS
EXTERNAL ZLADIV, LSAME, DLAMCH, ZLANHS
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN,
$ SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1
* ..
* .. Statement Function definitions ..
ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
* ..
* .. Executable Statements ..
*
* Decode JOB, COMPQ, COMPZ
*
IF( LSAME( JOB, 'E' ) ) THEN
ILSCHR = .FALSE.
ISCHUR = 1
ELSE IF( LSAME( JOB, 'S' ) ) THEN
ILSCHR = .TRUE.
ISCHUR = 2
ELSE
ILSCHR = .TRUE.
ISCHUR = 0
END IF
*
IF( LSAME( COMPQ, 'N' ) ) THEN
ILQ = .FALSE.
ICOMPQ = 1
ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 2
ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
ILQ = .TRUE.
ICOMPQ = 3
ELSE
ILQ = .TRUE.
ICOMPQ = 0
END IF
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ILZ = .FALSE.
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 2
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ILZ = .TRUE.
ICOMPZ = 3
ELSE
ILZ = .TRUE.
ICOMPZ = 0
END IF
*
* Check Argument Values
*
INFO = 0
WORK( 1 ) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 )
IF( ISCHUR.EQ.0 ) THEN
INFO = -1
ELSE IF( ICOMPQ.EQ.0 ) THEN
INFO = -2
ELSE IF( ICOMPZ.EQ.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 ) THEN
INFO = -5
ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
INFO = -6
ELSE IF( LDH.LT.N ) THEN
INFO = -8
ELSE IF( LDT.LT.N ) THEN
INFO = -10
ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
INFO = -14
ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -18
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHGEQZ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
* WORK( 1 ) = CMPLX( 1 )
IF( N.LE.0 ) THEN
WORK( 1 ) = DCMPLX( 1 )
RETURN
END IF
*
* Initialize Q and Z
*
IF( ICOMPQ.EQ.3 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
IF( ICOMPZ.EQ.3 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
* Machine Constants
*
IN = IHI + 1 - ILO
SAFMIN = DLAMCH( 'S' )
ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK )
BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK )
ATOL = MAX( SAFMIN, ULP*ANORM )
BTOL = MAX( SAFMIN, ULP*BNORM )
ASCALE = ONE / MAX( SAFMIN, ANORM )
BSCALE = ONE / MAX( SAFMIN, BNORM )
*
*
* Set Eigenvalues IHI+1:N
*
DO 10 J = IHI + 1, N
ABSB = ABS( T( J, J ) )
IF( ABSB.GT.SAFMIN ) THEN
SIGNBC = DCONJG( T( J, J ) / ABSB )
T( J, J ) = ABSB
IF( ILSCHR ) THEN
CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
ELSE
CALL ZSCAL( 1, SIGNBC, H( J, J ), 1 )
END IF
IF( ILZ )
$ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
ELSE
T( J, J ) = CZERO
END IF
ALPHA( J ) = H( J, J )
BETA( J ) = T( J, J )
10 CONTINUE
*
* If IHI < ILO, skip QZ steps
*
IF( IHI.LT.ILO )
$ GO TO 190
*
* MAIN QZ ITERATION LOOP
*
* Initialize dynamic indices
*
* Eigenvalues ILAST+1:N have been found.
* Column operations modify rows IFRSTM:whatever
* Row operations modify columns whatever:ILASTM
*
* If only eigenvalues are being computed, then
* IFRSTM is the row of the last splitting row above row ILAST;
* this is always at least ILO.
* IITER counts iterations since the last eigenvalue was found,
* to tell when to use an extraordinary shift.
* MAXIT is the maximum number of QZ sweeps allowed.
*
ILAST = IHI
IF( ILSCHR ) THEN
IFRSTM = 1
ILASTM = N
ELSE
IFRSTM = ILO
ILASTM = IHI
END IF
IITER = 0
ESHIFT = CZERO
MAXIT = 30*( IHI-ILO+1 )
*
DO 170 JITER = 1, MAXIT
*
* Check for too many iterations.
*
IF( JITER.GT.MAXIT )
$ GO TO 180
*
* Split the matrix if possible.
*
* Two tests:
* 1: H(j,j-1)=0 or j=ILO
* 2: T(j,j)=0
*
* Special case: j=ILAST
*
IF( ILAST.EQ.ILO ) THEN
GO TO 60
ELSE
IF( ABS1( H( ILAST, ILAST-1 ) ).LE.MAX( SAFMIN, ULP*(
$ ABS1( H( ILAST, ILAST ) ) + ABS1( H( ILAST-1, ILAST-1 )
$ ) ) ) ) THEN
H( ILAST, ILAST-1 ) = CZERO
GO TO 60
END IF
END IF
*
IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
T( ILAST, ILAST ) = CZERO
GO TO 50
END IF
*
* General case: j<ILAST
*
DO 40 J = ILAST - 1, ILO, -1
*
* Test 1: for H(j,j-1)=0 or j=ILO
*
IF( J.EQ.ILO ) THEN
ILAZRO = .TRUE.
ELSE
IF( ABS1( H( J, J-1 ) ).LE.MAX( SAFMIN, ULP*(
$ ABS1( H( J, J ) ) + ABS1( H( J-1, J-1 ) )
$ ) ) ) THEN
H( J, J-1 ) = CZERO
ILAZRO = .TRUE.
ELSE
ILAZRO = .FALSE.
END IF
END IF
*
* Test 2: for T(j,j)=0
*
IF( ABS( T( J, J ) ).LT.BTOL ) THEN
T( J, J ) = CZERO
*
* Test 1a: Check for 2 consecutive small subdiagonals in A
*
ILAZR2 = .FALSE.
IF( .NOT.ILAZRO ) THEN
IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1,
$ J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) )
$ ILAZR2 = .TRUE.
END IF
*
* If both tests pass (1 & 2), i.e., the leading diagonal
* element of B in the block is zero, split a 1x1 block off
* at the top. (I.e., at the J-th row/column) The leading
* diagonal element of the remainder can also be zero, so
* this may have to be done repeatedly.
*
IF( ILAZRO .OR. ILAZR2 ) THEN
DO 20 JCH = J, ILAST - 1
CTEMP = H( JCH, JCH )
CALL ZLARTG( CTEMP, H( JCH+1, JCH ), C, S,
$ H( JCH, JCH ) )
H( JCH+1, JCH ) = CZERO
CALL ZROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
$ H( JCH+1, JCH+1 ), LDH, C, S )
CALL ZROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
$ T( JCH+1, JCH+1 ), LDT, C, S )
IF( ILQ )
$ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ),
$ 1,
$ C, DCONJG( S ) )
IF( ILAZR2 )
$ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
ILAZR2 = .FALSE.
IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
IF( JCH+1.GE.ILAST ) THEN
GO TO 60
ELSE
IFIRST = JCH + 1
GO TO 70
END IF
END IF
T( JCH+1, JCH+1 ) = CZERO
20 CONTINUE
GO TO 50
ELSE
*
* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
* Then process as in the case T(ILAST,ILAST)=0
*
DO 30 JCH = J, ILAST - 1
CTEMP = T( JCH, JCH+1 )
CALL ZLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S,
$ T( JCH, JCH+1 ) )
T( JCH+1, JCH+1 ) = CZERO
IF( JCH.LT.ILASTM-1 )
$ CALL ZROT( ILASTM-JCH-1, T( JCH, JCH+2 ),
$ LDT,
$ T( JCH+1, JCH+2 ), LDT, C, S )
CALL ZROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
$ H( JCH+1, JCH-1 ), LDH, C, S )
IF( ILQ )
$ CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ),
$ 1,
$ C, DCONJG( S ) )
CTEMP = H( JCH+1, JCH )
CALL ZLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S,
$ H( JCH+1, JCH ) )
H( JCH+1, JCH-1 ) = CZERO
CALL ZROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
$ H( IFRSTM, JCH-1 ), 1, C, S )
CALL ZROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
$ T( IFRSTM, JCH-1 ), 1, C, S )
IF( ILZ )
$ CALL ZROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ),
$ 1,
$ C, S )
30 CONTINUE
GO TO 50
END IF
ELSE IF( ILAZRO ) THEN
*
* Only test 1 passed -- work on J:ILAST
*
IFIRST = J
GO TO 70
END IF
*
* Neither test passed -- try next J
*
40 CONTINUE
*
* (Drop-through is "impossible")
*
INFO = 2*N + 1
GO TO 210
*
* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
* 1x1 block.
*
50 CONTINUE
CTEMP = H( ILAST, ILAST )
CALL ZLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S,
$ H( ILAST, ILAST ) )
H( ILAST, ILAST-1 ) = CZERO
CALL ZROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
$ H( IFRSTM, ILAST-1 ), 1, C, S )
CALL ZROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
$ T( IFRSTM, ILAST-1 ), 1, C, S )
IF( ILZ )
$ CALL ZROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C,
$ S )
*
* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA
*
60 CONTINUE
ABSB = ABS( T( ILAST, ILAST ) )
IF( ABSB.GT.SAFMIN ) THEN
SIGNBC = DCONJG( T( ILAST, ILAST ) / ABSB )
T( ILAST, ILAST ) = ABSB
IF( ILSCHR ) THEN
CALL ZSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ),
$ 1 )
CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM,
$ ILAST ),
$ 1 )
ELSE
CALL ZSCAL( 1, SIGNBC, H( ILAST, ILAST ), 1 )
END IF
IF( ILZ )
$ CALL ZSCAL( N, SIGNBC, Z( 1, ILAST ), 1 )
ELSE
T( ILAST, ILAST ) = CZERO
END IF
ALPHA( ILAST ) = H( ILAST, ILAST )
BETA( ILAST ) = T( ILAST, ILAST )
*
* Go to next block -- exit if finished.
*
ILAST = ILAST - 1
IF( ILAST.LT.ILO )
$ GO TO 190
*
* Reset counters
*
IITER = 0
ESHIFT = CZERO
IF( .NOT.ILSCHR ) THEN
ILASTM = ILAST
IF( IFRSTM.GT.ILAST )
$ IFRSTM = ILO
END IF
GO TO 160
*
* QZ step
*
* This iteration only involves rows/columns IFIRST:ILAST. We
* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
*
70 CONTINUE
IITER = IITER + 1
IF( .NOT.ILSCHR ) THEN
IFRSTM = IFIRST
END IF
*
* Compute the Shift.
*
* At this point, IFIRST < ILAST, and the diagonal elements of
* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
* magnitude)
*
IF( ( IITER / 10 )*10.NE.IITER ) THEN
*
* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
* the bottom-right 2x2 block of A inv(B) which is nearest to
* the bottom-right element.
*
* We factor B as U*D, where U has unit diagonals, and
* compute (A*inv(D))*inv(U).
*
U12 = ( BSCALE*T( ILAST-1, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
$ ( BSCALE*T( ILAST-1, ILAST-1 ) )
AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) )
ABI22 = AD22 - U12*AD21
ABI12 = AD12 - U12*AD11
*
SHIFT = ABI22
CTEMP = SQRT( ABI12 )*SQRT( AD21 )
TEMP = ABS1( CTEMP )
IF( CTEMP.NE.ZERO ) THEN
X = HALF*( AD11-SHIFT )
TEMP2 = ABS1( X )
TEMP = MAX( TEMP, ABS1( X ) )
Y = TEMP*SQRT( ( X / TEMP )**2+( CTEMP / TEMP )**2 )
IF( TEMP2.GT.ZERO ) THEN
IF( DBLE( X / TEMP2 )*DBLE( Y )+
$ DIMAG( X / TEMP2 )*DIMAG( Y ).LT.ZERO )Y = -Y
END IF
SHIFT = SHIFT - CTEMP*ZLADIV( CTEMP, ( X+Y ) )
END IF
ELSE
*
* Exceptional shift. Chosen for no particularly good reason.
*
IF( ( IITER / 20 )*20.EQ.IITER .AND.
$ BSCALE*ABS1(T( ILAST, ILAST )).GT.SAFMIN ) THEN
ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
$ ILAST ) )/( BSCALE*T( ILAST, ILAST ) )
ELSE
ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
$ ILAST-1 ) )/( BSCALE*T( ILAST-1, ILAST-1 ) )
END IF
SHIFT = ESHIFT
END IF
*
* Now check for two consecutive small subdiagonals.
*
DO 80 J = ILAST - 1, IFIRST + 1, -1
ISTART = J
CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) )
TEMP = ABS1( CTEMP )
TEMP2 = ASCALE*ABS1( H( J+1, J ) )
TEMPR = MAX( TEMP, TEMP2 )
IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
TEMP = TEMP / TEMPR
TEMP2 = TEMP2 / TEMPR
END IF
IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL )
$ GO TO 90
80 CONTINUE
*
ISTART = IFIRST
CTEMP = ASCALE*H( IFIRST, IFIRST ) -
$ SHIFT*( BSCALE*T( IFIRST, IFIRST ) )
90 CONTINUE
*
* Do an implicit-shift QZ sweep.
*
* Initial Q
*
CTEMP2 = ASCALE*H( ISTART+1, ISTART )
CALL ZLARTG( CTEMP, CTEMP2, C, S, CTEMP3 )
*
* Sweep
*
DO 150 J = ISTART, ILAST - 1
IF( J.GT.ISTART ) THEN
CTEMP = H( J, J-1 )
CALL ZLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
H( J+1, J-1 ) = CZERO
END IF
*
DO 100 JC = J, ILASTM
CTEMP = C*H( J, JC ) + S*H( J+1, JC )
H( J+1, JC ) = -DCONJG( S )*H( J, JC ) + C*H( J+1, JC )
H( J, JC ) = CTEMP
CTEMP2 = C*T( J, JC ) + S*T( J+1, JC )
T( J+1, JC ) = -DCONJG( S )*T( J, JC ) + C*T( J+1, JC )
T( J, JC ) = CTEMP2
100 CONTINUE
IF( ILQ ) THEN
DO 110 JR = 1, N
CTEMP = C*Q( JR, J ) + DCONJG( S )*Q( JR, J+1 )
Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
Q( JR, J ) = CTEMP
110 CONTINUE
END IF
*
CTEMP = T( J+1, J+1 )
CALL ZLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
T( J+1, J ) = CZERO
*
DO 120 JR = IFRSTM, MIN( J+2, ILAST )
CTEMP = C*H( JR, J+1 ) + S*H( JR, J )
H( JR, J ) = -DCONJG( S )*H( JR, J+1 ) + C*H( JR, J )
H( JR, J+1 ) = CTEMP
120 CONTINUE
DO 130 JR = IFRSTM, J
CTEMP = C*T( JR, J+1 ) + S*T( JR, J )
T( JR, J ) = -DCONJG( S )*T( JR, J+1 ) + C*T( JR, J )
T( JR, J+1 ) = CTEMP
130 CONTINUE
IF( ILZ ) THEN
DO 140 JR = 1, N
CTEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
Z( JR, J ) = -DCONJG( S )*Z( JR, J+1 ) + C*Z( JR, J )
Z( JR, J+1 ) = CTEMP
140 CONTINUE
END IF
150 CONTINUE
*
160 CONTINUE
*
170 CONTINUE
*
* Drop-through = non-convergence
*
180 CONTINUE
INFO = ILAST
GO TO 210
*
* Successful completion of all QZ steps
*
190 CONTINUE
*
* Set Eigenvalues 1:ILO-1
*
DO 200 J = 1, ILO - 1
ABSB = ABS( T( J, J ) )
IF( ABSB.GT.SAFMIN ) THEN
SIGNBC = DCONJG( T( J, J ) / ABSB )
T( J, J ) = ABSB
IF( ILSCHR ) THEN
CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
ELSE
CALL ZSCAL( 1, SIGNBC, H( J, J ), 1 )
END IF
IF( ILZ )
$ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
ELSE
T( J, J ) = CZERO
END IF
ALPHA( J ) = H( J, J )
BETA( J ) = T( J, J )
200 CONTINUE
*
* Normal Termination
*
INFO = 0
*
* Exit (other than argument error) -- return optimal workspace size
*
210 CONTINUE
WORK( 1 ) = DCMPLX( N )
RETURN
*
* End of ZHGEQZ
*
END
*> \brief \b ZHPCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhpcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhpcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhpcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPCON estimates the reciprocal of the condition number of a complex
*> Hermitian packed matrix A using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by ZHPTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZHPTRF, stored as a
*> packed triangular matrix.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZHPTRF.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*
*> \ingroup hpcon
*
* =====================================================================
SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IP, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHPTRS, ZLACN2
* ..
* .. 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( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
IP = N*( N+1 ) / 2
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP - I
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
IP = 1
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP + N - I + 1
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
*
CALL ZHPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of ZHPCON
*
END
*> \brief <b> ZHPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPEV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhpev.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhpev.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhpev.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
*> complex Hermitian matrix in packed storage.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, AP is overwritten by values generated during the
*> reduction to tridiagonal form. If UPLO = 'U', the diagonal
*> and first superdiagonal of the tridiagonal matrix T overwrite
*> the corresponding elements of A, and if UPLO = 'L', the
*> diagonal and first subdiagonal of T overwrite the
*> corresponding elements of A.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
*> eigenvectors of the matrix A, with the i-th column of Z
*> holding the eigenvector associated with W(i).
*> If JOBZ = '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
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (max(1, 2*N-1))
*> \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.
*
*> \ingroup hpev
*
* =====================================================================
SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK,
$ INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
$ ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHP
EXTERNAL LSAME, DLAMCH, ZLANHP
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD,
$ ZSTEQR,
$ ZUPGTR
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR.
$ LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = DBLE( AP( 1 ) )
RWORK( 1 ) = 1
IF( WANTZ )
$ Z( 1, 1 ) = ONE
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 = ZLANHP( 'M', UPLO, N, AP, 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 ) THEN
CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
$ IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
INDRWK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
$ RWORK( INDRWK ), 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
*
RETURN
*
* End of ZHPEV
*
END
*> \brief \b ZHPTRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPTRD + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhptrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhptrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhptrd.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 AP( * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPTRD reduces a complex Hermitian matrix A stored in packed form 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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*> 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[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.
*
*> \ingroup hptrd
*
*> \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 AP,
*> overwriting A(1:i-1,i+1), and tau is stored 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 AP,
*> overwriting A(i+2:n,i), and tau is stored in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 AP( * ), 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, I1, I1I1, II
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) )
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 = AP( I1+I-1 )
CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
E( I ) = DBLE( ALPHA )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y**H *v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 )
CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
END IF
AP( I1+I-1 ) = E( I )
D( I+1 ) = DBLE( AP( I1+I ) )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = DBLE( AP( 1 ) )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
AP( 1 ) = DBLE( AP( 1 ) )
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(i+2:n,i)
*
ALPHA = AP( II+1 )
CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
E( I ) = DBLE( ALPHA )
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ),
$ 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y**H *v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1,
$ AP( II+1 ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ),
$ 1,
$ AP( I1I1 ) )
*
END IF
AP( II+1 ) = E( I )
D( I ) = DBLE( AP( II ) )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = DBLE( AP( II ) )
END IF
*
RETURN
*
* End of ZHPTRD
*
END
*> \brief \b ZHPTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhptrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhptrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhptrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPTRF computes the factorization of a complex Hermitian packed
*> matrix A using the Bunch-Kaufman diagonal pivoting method:
*>
*> A = U*D*U**H or A = L*D*L**H
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is Hermitian and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L, stored as a packed triangular
*> matrix overwriting A (see below for further details).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \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, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hptrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**H, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**H, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> J. Lewis, Boeing Computer Services Company
*
* =====================================================================
SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
$ KSTEP, KX, NPP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
$ TT
COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAPY2
EXTERNAL LSAME, IZAMAX, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHPR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
* ..
* .. 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' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRF', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**H using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
KC = ( N-1 )*N / 2 + 1
10 CONTINUE
KNC = KC
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( AP( KC+K-1 ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, AP( KC ), 1 )
COLMAX = CABS1( AP( KC+IMAX-1 ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
JMAX = IMAX
KX = IMAX*( IMAX+1 ) / 2 + IMAX
DO 20 J = IMAX + 1, K
IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = CABS1( AP( KX ) )
JMAX = J
END IF
KX = KX + J
20 CONTINUE
KPC = ( IMAX-1 )*IMAX / 2 + 1
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( DBLE( AP( KPC+IMAX-1 ) ) ).GE.ALPHA*
$ ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KSTEP.EQ.2 )
$ KNC = KNC - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL ZSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 30 J = KP + 1, KK - 1
KX = KX + J - 1
T = DCONJG( AP( KNC+J-1 ) )
AP( KNC+J-1 ) = DCONJG( AP( KX ) )
AP( KX ) = T
30 CONTINUE
AP( KX+KK-1 ) = DCONJG( AP( KX+KK-1 ) )
R1 = DBLE( AP( KNC+KK-1 ) )
AP( KNC+KK-1 ) = DBLE( AP( KPC+KP-1 ) )
AP( KPC+KP-1 ) = R1
IF( KSTEP.EQ.2 ) THEN
AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
T = AP( KC+K-2 )
AP( KC+K-2 ) = AP( KC+KP-1 )
AP( KC+KP-1 ) = T
END IF
ELSE
AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
IF( KSTEP.EQ.2 )
$ AP( KC-1 ) = DBLE( AP( KC-1 ) )
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)**H = A - W(k)*1/D(k)*W(k)**H
*
R1 = ONE / DBLE( AP( KC+K-1 ) )
CALL ZHPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
*
* Store U(k) in column k
*
CALL ZDSCAL( K-1, R1, AP( KC ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**H
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H
*
IF( K.GT.2 ) THEN
*
D = DLAPY2( DBLE( AP( K-1+( K-1 )*K / 2 ) ),
$ DIMAG( AP( K-1+( K-1 )*K / 2 ) ) )
D22 = DBLE( AP( K-1+( K-2 )*( K-1 ) / 2 ) ) / D
D11 = DBLE( AP( K+( K-1 )*K / 2 ) ) / D
TT = ONE / ( D11*D22-ONE )
D12 = AP( K-1+( K-1 )*K / 2 ) / D
D = TT / D
*
DO 50 J = K - 2, 1, -1
WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
$ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) )
WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12*
$ AP( J+( K-2 )*( K-1 ) / 2 ) )
DO 40 I = J, 1, -1
AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
$ AP( I+( K-1 )*K / 2 )*DCONJG( WK ) -
$ AP( I+( K-2 )*( K-1 ) / 2 )*DCONJG( WKM1 )
40 CONTINUE
AP( J+( K-1 )*K / 2 ) = WK
AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
AP( J+( J-1 )*J / 2 ) = DCMPLX( DBLE( AP( J+( J-
$ 1 )*J / 2 ) ), 0.0D+0 )
50 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
KC = KNC - K
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**H using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
KC = 1
NPP = N*( N+1 ) / 2
60 CONTINUE
KNC = KC
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( AP( KC ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, AP( KC+1 ), 1 )
COLMAX = CABS1( AP( KC+IMAX-K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
AP( KC ) = DBLE( AP( KC ) )
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
KX = KC + IMAX - K
DO 70 J = K, IMAX - 1
IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = CABS1( AP( KX ) )
JMAX = J
END IF
KX = KX + N - J
70 CONTINUE
KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, AP( KPC+1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( ABS( DBLE( AP( KPC ) ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KSTEP.EQ.2 )
$ KNC = KNC + N - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, AP( KNC+KP-KK+1 ), 1,
$ AP( KPC+1 ),
$ 1 )
KX = KNC + KP - KK
DO 80 J = KK + 1, KP - 1
KX = KX + N - J + 1
T = DCONJG( AP( KNC+J-KK ) )
AP( KNC+J-KK ) = DCONJG( AP( KX ) )
AP( KX ) = T
80 CONTINUE
AP( KNC+KP-KK ) = DCONJG( AP( KNC+KP-KK ) )
R1 = DBLE( AP( KNC ) )
AP( KNC ) = DBLE( AP( KPC ) )
AP( KPC ) = R1
IF( KSTEP.EQ.2 ) THEN
AP( KC ) = DBLE( AP( KC ) )
T = AP( KC+1 )
AP( KC+1 ) = AP( KC+KP-K )
AP( KC+KP-K ) = T
END IF
ELSE
AP( KC ) = DBLE( AP( KC ) )
IF( KSTEP.EQ.2 )
$ AP( KNC ) = DBLE( AP( KNC ) )
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)**H = A - W(k)*(1/D(k))*W(k)**H
*
R1 = ONE / DBLE( AP( KC ) )
CALL ZHPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
$ AP( KC+N-K+1 ) )
*
* Store L(k) in column K
*
CALL ZDSCAL( N-K, R1, AP( KC+1 ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns K and K+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**H
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D = DLAPY2(
$ DBLE( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ),
$ DIMAG( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ) )
D11 = DBLE( AP( K+1+K*( 2*N-K-1 ) / 2 ) ) / D
D22 = DBLE( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D
TT = ONE / ( D11*D22-ONE )
D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D
D = TT / D
*
DO 100 J = K + 2, N
WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21*
$ AP( J+K*( 2*N-K-1 ) / 2 ) )
WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
$ DCONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) /
$ 2 ) )
DO 90 I = J, N
AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
$ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
$ 2 )*DCONJG( WK ) - AP( I+K*( 2*N-K-1 ) / 2 )*
$ DCONJG( WKP1 )
90 CONTINUE
AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
AP( J+( J-1 )*( 2*N-J ) / 2 )
$ = DCMPLX( DBLE( AP( J+( J-1 )*( 2*N-J ) / 2 ) ),
$ 0.0D+0 )
100 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
KC = KNC + N - K + 2
GO TO 60
*
END IF
*
110 CONTINUE
RETURN
*
* End of ZHPTRF
*
END
*> \brief \b ZHPTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhptri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhptri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhptri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
*> A in packed storage using the factorization A = U*D*U**H or
*> A = L*D*L**H computed by ZHPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by ZHPTRF,
*> stored as a packed triangular matrix.
*>
*> On exit, if INFO = 0, the (Hermitian) inverse of the original
*> matrix, stored as a packed triangular matrix. The j-th column
*> of inv(A) is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
*> if UPLO = 'L',
*> AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZHPTRF.
*> \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
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hptri
*
* =====================================================================
SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
COMPLEX*16 CONE, ZERO
PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
DOUBLE PRECISION AK, AKP1, D, T
COMPLEX*16 AKKP1, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZHPMV, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
KP = N*( N+1 ) / 2
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP - INFO
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
KP = 1
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**H.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
KCNEXT = KC + K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC+K-1 ) = ONE / DBLE( AP( KC+K-1 ) )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
$ AP( KC ), 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ DBLE( ZDOTC( K-1, WORK, 1, AP( KC ),
$ 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+K-1 ) )
AK = DBLE( AP( KC+K-1 ) ) / T
AKP1 = DBLE( AP( KCNEXT+K ) ) / T
AKKP1 = AP( KCNEXT+K-1 ) / T
D = T*( AK*AKP1-ONE )
AP( KC+K-1 ) = AKP1 / D
AP( KCNEXT+K ) = AK / D
AP( KCNEXT+K-1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
$ AP( KC ), 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ DBLE( ZDOTC( K-1, WORK, 1, AP( KC ),
$ 1 ) )
AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
$ ZDOTC( K-1, AP( KC ), 1,
$ AP( KCNEXT ),
$ 1 )
CALL ZCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
$ AP( KCNEXT ), 1 )
AP( KCNEXT+K ) = AP( KCNEXT+K ) -
$ DBLE( ZDOTC( K-1, WORK, 1,
$ AP( KCNEXT ),
$ 1 ) )
END IF
KSTEP = 2
KCNEXT = KCNEXT + K + 1
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
KPC = ( KP-1 )*KP / 2 + 1
CALL ZSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 40 J = KP + 1, K - 1
KX = KX + J - 1
TEMP = DCONJG( AP( KC+J-1 ) )
AP( KC+J-1 ) = DCONJG( AP( KX ) )
AP( KX ) = TEMP
40 CONTINUE
AP( KC+KP-1 ) = DCONJG( AP( KC+KP-1 ) )
TEMP = AP( KC+K-1 )
AP( KC+K-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC+K+K-1 )
AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
AP( KC+K+KP-1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
KC = KCNEXT
GO TO 30
50 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**H.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
NPP = N*( N+1 ) / 2
K = N
KC = NPP
60 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 80
*
KCNEXT = KC - ( N-K+2 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC ) = ONE / DBLE( AP( KC ) )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+N-K+1 ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - DBLE( ZDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = ABS( AP( KCNEXT+1 ) )
AK = DBLE( AP( KCNEXT ) ) / T
AKP1 = DBLE( AP( KC ) ) / T
AKKP1 = AP( KCNEXT+1 ) / T
D = T*( AK*AKP1-ONE )
AP( KCNEXT ) = AKP1 / D
AP( KC ) = AK / D
AP( KCNEXT+1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ),
$ WORK,
$ 1, ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - DBLE( ZDOTC( N-K, WORK, 1,
$ AP( KC+1 ), 1 ) )
AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
$ ZDOTC( N-K, AP( KC+1 ), 1,
$ AP( KCNEXT+2 ), 1 )
CALL ZCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ),
$ WORK,
$ 1, ZERO, AP( KCNEXT+2 ), 1 )
AP( KCNEXT ) = AP( KCNEXT ) -
$ DBLE( ZDOTC( N-K, WORK, 1,
$ AP( KCNEXT+2 ),
$ 1 ) )
END IF
KSTEP = 2
KCNEXT = KCNEXT - ( N-K+3 )
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
KX = KC + KP - K
DO 70 J = K + 1, KP - 1
KX = KX + N - J + 1
TEMP = DCONJG( AP( KC+J-K ) )
AP( KC+J-K ) = DCONJG( AP( KX ) )
AP( KX ) = TEMP
70 CONTINUE
AP( KC+KP-K ) = DCONJG( AP( KC+KP-K ) )
TEMP = AP( KC )
AP( KC ) = AP( KPC )
AP( KPC ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC-N+K-1 )
AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
AP( KC-N+KP-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
KC = KCNEXT
GO TO 60
80 CONTINUE
END IF
*
RETURN
*
* End of ZHPTRI
*
END
*> \brief \b ZHPTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhptrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhptrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhptrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPTRS solves a system of linear equations A*X = B with a complex
*> Hermitian matrix A stored in packed format using the factorization
*> A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**H;
*> = 'L': Lower triangular, form is A = L*D*L**H.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZHPTRF, stored as a
*> packed triangular matrix.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZHPTRF.
*> \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.
*
*> \ingroup hptrs
*
* =====================================================================
SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KP
DOUBLE PRECISION S
COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV,
$ ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCONJG, MAX
* ..
* .. Executable Statements ..
*
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( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**H.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
KC = KC - K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = DBLE( ONE ) / DBLE( AP( KC+K-1 ) )
CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL ZGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL ZGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
$ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+K-2 )
AKM1 = AP( KC-1 ) / AKM1K
AK = AP( KC+K-1 ) / DCONJG( AKM1K )
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / DCONJG( AKM1K )
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
KC = KC - K + 1
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**H *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**H(K)), where U(K) is the transformation
* stored in column K of A.
*
IF( K.GT.1 ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.GT.1 ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
*
CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
$ LDB, AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + 2*K + 1
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**H.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
S = DBLE( ONE ) / DBLE( AP( KC ) )
CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K,
$ 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+1 )
AKM1 = AP( KC ) / DCONJG( AKM1K )
AK = AP( KC+N-K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / DCONJG( AKM1K )
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
KC = KC + 2*( N-K ) + 1
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**H *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
KC = KC - ( N-K+1 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**H(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
$ B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
END IF
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
$ B( K, 1 ), LDB )
CALL ZLACGV( NRHS, B( K, 1 ), LDB )
*
CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
$ B( K+1, 1 ), LDB, AP( KC-( N-K ) ), 1, ONE,
$ B( K-1, 1 ), LDB )
CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC - ( N-K+2 )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of ZHPTRS
*
END
*> \brief \b ZHSEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHSEQR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhseqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhseqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhseqr.f">
*> [TXT]</a>
*> \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 >= 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 > 0, then 1 <= ILO <= IHI <= 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 > 0 is given under the description of INFO below.)
*>
*> Unlike earlier versions of ZHSEQR, this subroutine may
*> explicitly H(i,j) = 0 for i > 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 >= 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 > 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 >= MAX(1,N). Otherwise, LDZ >= 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 >= 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
*> < 0: if INFO = -i, the i-th argument had an illegal
*> value
*> > 0: if INFO = i, ZHSEQR failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of W
*> contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO > 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 > 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 > 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 > 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 > 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.
*
*> \ingroup hseqr
*
*> \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) <= 500 is NS.
*> The default for (IHI-ILO+1) > 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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 = 15 )
*
* ==== NL allocates some local workspace to help small matrices
* . through a rare ZLAHQR failure. NL > NTINY = 15 is
* . required and NL <= 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlabrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlabrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlabrd.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup labrd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ) = DBLE( 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 ) = DBLE( 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 ) = DBLE( 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 ) = DBLE( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacgv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacgv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacgv.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lacgv
*
* =====================================================================
SUBROUTINE ZLACGV( N, X, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacn2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacn2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacn2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lacn2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacp2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacp2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacp2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lacp2
*
* =====================================================================
SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacpy.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacpy.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacpy.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lacpy
*
* =====================================================================
SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlacrm.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlacrm.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlacrm.f">
*> [TXT]</a>
*> \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)
*> On entry, 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)
*> On entry, 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[out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> On exit, 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.
*
*> \ingroup lacrm
*
* =====================================================================
SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zladiv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zladiv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zladiv.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ladiv
*
* =====================================================================
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ZLAED0 used by ZSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAED0 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed0.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed0.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed0.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
* IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Using the divide and conquer method, ZLAED0 computes all eigenvalues
*> of a symmetric tridiagonal matrix which is one diagonal block of
*> those from reducing a dense or band Hermitian matrix and
*> corresponding eigenvectors of the dense or band matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal 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, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the off-diagonal elements of the tridiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, Q must contain an QSIZ x N matrix whose columns
*> unitarily orthonormal. It is a part of the unitary matrix
*> that reduces the full dense Hermitian matrix to a
*> (reducible) symmetric tridiagonal matrix.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array,
*> the dimension of IWORK must be at least
*> 6 + 6*N + 5*N*lg N
*> ( lg( N ) = smallest integer k
*> such that 2^k >= N )
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array,
*> dimension (1 + 3*N + 2*N*lg N + 3*N**2)
*> ( lg( N ) = smallest integer k
*> such that 2^k >= N )
*> \endverbatim
*>
*> \param[out] QSTORE
*> \verbatim
*> QSTORE is COMPLEX*16 array, dimension (LDQS, N)
*> Used to store parts of
*> the eigenvector matrix when the updating matrix multiplies
*> take place.
*> \endverbatim
*>
*> \param[in] LDQS
*> \verbatim
*> LDQS is INTEGER
*> The leading dimension of the array QSTORE.
*> LDQS >= 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: The algorithm failed to compute an eigenvalue 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.
*
*> \ingroup laed0
*
* =====================================================================
SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
$ IWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
* =====================================================================
*
* Warning: N could be as big as QSIZ!
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.D+0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
$ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM,
$ ZLAED7
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
* INFO = -1
* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
* $ THEN
IF( QSIZ.LT.MAX( 0, N ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
* Initialize pointers
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
LL = IQ - 1 + IWORK( IQPTR+CURR )
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ RWORK( LL ), MATSIZ, RWORK, INFO )
CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
$ MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
$ RWORK( IWREM ) )
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ. ZLAED7 handles the case
* when the eigenvectors of a full or band Hermitian matrix (which
* was reduced to tridiagonal form) are desired.
*
* I am free to use Q as a valuable working space until Loop 150.
*
CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
$ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
$ IWORK( IPERM ), IWORK( IGIVPT ),
$ IWORK( IGIVCL ), RWORK( IGIVNM ),
$ Q( 1, SUBMAT ), RWORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
DO 100 I = 1, N
J = IWORK( INDXQ+I )
RWORK( I ) = D( J )
CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, RWORK, 1, D, 1 )
*
RETURN
*
* End of ZLAED0
*
END
*> \brief \b ZLAED7 used by ZSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAED7 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed7.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed7.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed7.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
* LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
* GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
* $ TLVLS
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
* COMPLEX*16 Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAED7 computes the updated eigensystem of a diagonal
*> matrix after modification by a rank-one symmetric matrix. This
*> routine is used only for the eigenproblem which requires all
*> eigenvalues and optionally eigenvectors of a dense or banded
*> Hermitian matrix that has been reduced to tridiagonal form.
*>
*> T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
*>
*> where Z = Q**Hu, u is a vector of length N with ones in the
*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*>
*> The eigenvectors of the original matrix are stored in Q, and the
*> eigenvalues are in D. The algorithm consists of three stages:
*>
*> The first stage consists of deflating the size of the problem
*> when there are multiple eigenvalues or if there is a zero in
*> the Z vector. For each such occurrence the dimension of the
*> secular equation problem is reduced by one. This stage is
*> performed by the routine DLAED2.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine DLAED4 (as called by SLAED3).
*> This routine also calculates the eigenvectors of the current
*> problem.
*>
*> The final stage consists of computing the updated eigenvectors
*> directly using the updated eigenvalues. The eigenvectors for
*> the current problem are multiplied with the eigenvectors from
*> the overall problem.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> Contains the location of the last eigenvalue in the leading
*> sub-matrix. min(1,N) <= CUTPNT <= N.
*> \endverbatim
*>
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N.
*> \endverbatim
*>
*> \param[in] TLVLS
*> \verbatim
*> TLVLS is INTEGER
*> The total number of merging levels in the overall divide and
*> conquer tree.
*> \endverbatim
*>
*> \param[in] CURLVL
*> \verbatim
*> CURLVL is INTEGER
*> The current level in the overall merge routine,
*> 0 <= curlvl <= tlvls.
*> \endverbatim
*>
*> \param[in] CURPBM
*> \verbatim
*> CURPBM is INTEGER
*> The current problem in the current level in the overall
*> merge routine (counting from upper left to lower right).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the eigenvalues of the rank-1-perturbed matrix.
*> On exit, the eigenvalues of the repaired matrix.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, the eigenvectors of the rank-1-perturbed matrix.
*> On exit, the eigenvectors of the repaired tridiagonal matrix.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> Contains the subdiagonal element used to create the rank-1
*> modification.
*> \endverbatim
*>
*> \param[out] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> This contains the permutation which will reintegrate the
*> subproblem just solved back into sorted order,
*> ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (4*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array,
*> dimension (3*N+2*QSIZ*N)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (QSIZ*N)
*> \endverbatim
*>
*> \param[in,out] QSTORE
*> \verbatim
*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1)
*> Stores eigenvectors of submatrices encountered during
*> divide and conquer, packed together. QPTR points to
*> beginning of the submatrices.
*> \endverbatim
*>
*> \param[in,out] QPTR
*> \verbatim
*> QPTR is INTEGER array, dimension (N+2)
*> List of indices pointing to beginning of submatrices stored
*> in QSTORE. The submatrices are numbered starting at the
*> bottom left of the divide and conquer tree, from left to
*> right and bottom to top.
*> \endverbatim
*>
*> \param[in] PRMPTR
*> \verbatim
*> PRMPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in PERM a
*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
*> indicates the size of the permutation and also the size of
*> the full, non-deflated problem.
*> \endverbatim
*>
*> \param[in] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N lg N)
*> Contains the permutations (from deflation and sorting) to be
*> applied to each eigenblock.
*> \endverbatim
*>
*> \param[in] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in GIVCOL a
*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
*> indicates the number of Givens rotations.
*> \endverbatim
*>
*> \param[in] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension (2, N lg N)
*> Each pair of numbers indicates a pair of columns to take place
*> in a Givens rotation.
*> \endverbatim
*>
*> \param[in] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \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 = 1, an eigenvalue did not converge
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laed7
*
* =====================================================================
SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D,
$ Q,
$ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
$ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
$ TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX,
$ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM,
$ ZLAED8
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
* INFO = -1
* ELSE IF( N.LT.0 ) THEN
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
$ RWORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
$ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
$ IWORK( INDXP ), IWORK( INDX ), INDXQ,
$ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
$ RWORK( IDLMDA ), RWORK( IW ),
$ QSTORE( QPTR( CURR ) ), K, INFO )
CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K,
$ Q,
$ LDQ, RWORK( IQ ) )
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
RETURN
*
* End of ZLAED7
*
END
*> \brief \b ZLAED8 used by ZSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAED8 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaed8.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaed8.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaed8.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMBDA,
* Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
* GIVCOL, GIVNUM, INFO )
*
* .. Scalar Arguments ..
* INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
* $ INDXQ( * ), PERM( * )
* DOUBLE PRECISION D( * ), DLAMBDA( * ), GIVNUM( 2, * ), W( * ),
* $ Z( * )
* COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAED8 merges the two sets of eigenvalues together into a single
*> sorted set. Then it tries to deflate the size of the problem.
*> There are two ways in which deflation can occur: when two or more
*> eigenvalues are close together or if there is a tiny element in the
*> Z vector. For each such occurrence the order of the related secular
*> equation problem is reduced by one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[out] K
*> \verbatim
*> K is INTEGER
*> Contains the number of non-deflated eigenvalues.
*> This is the order of the related secular equation.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the dense or band matrix to tridiagonal form.
*> QSIZ >= N if ICOMPQ = 1.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, Q contains the eigenvectors of the partially solved
*> system which has been previously updated in matrix
*> multiplies with other partially solved eigensystems.
*> On exit, Q contains the trailing (N-K) updated eigenvectors
*> (those which were deflated) in its last N-K columns.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max( 1, N ).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, D contains the eigenvalues of the two submatrices to
*> be combined. On exit, D contains the trailing (N-K) updated
*> eigenvalues (those which were deflated) sorted into increasing
*> order.
*> \endverbatim
*>
*> \param[in,out] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> Contains the off diagonal element associated with the rank-1
*> cut which originally split the two submatrices which are now
*> being recombined. RHO is modified during the computation to
*> the value required by DLAED3.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> Contains the location of the last eigenvalue in the leading
*> sub-matrix. MIN(1,N) <= CUTPNT <= N.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (N)
*> On input this vector contains the updating vector (the last
*> row of the first sub-eigenvector matrix and the first row of
*> the second sub-eigenvector matrix). The contents of Z are
*> destroyed during the updating process.
*> \endverbatim
*>
*> \param[out] DLAMBDA
*> \verbatim
*> DLAMBDA is DOUBLE PRECISION array, dimension (N)
*> Contains a copy of the first K eigenvalues which will be used
*> by DLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is COMPLEX*16 array, dimension (LDQ2,N)
*> If ICOMPQ = 0, Q2 is not referenced. Otherwise,
*> Contains a copy of the first K eigenvectors which will be used
*> by DLAED7 in a matrix multiply (DGEMM) to update the new
*> eigenvectors.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of the array Q2. LDQ2 >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> This will hold the first k values of the final
*> deflation-altered z-vector and will be passed to DLAED3.
*> \endverbatim
*>
*> \param[out] INDXP
*> \verbatim
*> INDXP is INTEGER array, dimension (N)
*> This will contain the permutation used to place deflated
*> values of D at the end of the array. On output INDXP(1:K)
*> points to the nondeflated D-values and INDXP(K+1:N)
*> points to the deflated eigenvalues.
*> \endverbatim
*>
*> \param[out] INDX
*> \verbatim
*> INDX is INTEGER array, dimension (N)
*> This will contain the permutation used to sort the contents of
*> D into ascending order.
*> \endverbatim
*>
*> \param[in] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> This contains the permutation which separately sorts the two
*> sub-problems in D into ascending order. Note that elements in
*> the second half of this permutation must first have CUTPNT
*> added to their values in order to be accurate.
*> \endverbatim
*>
*> \param[out] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N)
*> Contains the permutations (from deflation and sorting) to be
*> applied to each eigenblock.
*> \endverbatim
*>
*> \param[out] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER
*> Contains the number of Givens rotations which took place in
*> this subproblem.
*> \endverbatim
*>
*> \param[out] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension (2, N)
*> Each pair of numbers indicates a pair of columns to take place
*> in a Givens rotation.
*> \endverbatim
*>
*> \param[out] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension (2, N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \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.
*
*> \ingroup laed8
*
* =====================================================================
SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z,
$ DLAMBDA,
$ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMBDA( * ), GIVNUM( 2, * ), W( * ),
$ Z( * )
COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY,
$ ZDROT,
$ ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -8
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED8', -INFO )
RETURN
END IF
*
* Need to initialize GIVPTR to O here in case of quick exit
* to prevent an unspecified code behavior (usually sigfault)
* when IWORK array on entry to *stedc is not zeroed
* (or at least some IWORK entries which used in *laed7 for GIVPTR).
*
GIVPTR = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMBDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( N1, N2, DLAMBDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMBDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* -- except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
50 CONTINUE
CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
K2 = N + 1
DO 60 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JLAM = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
80 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 80
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMBDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 70
90 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMBDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
100 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMBDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMBDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
DO 110 J = 1, N
JP = INDXP( J )
DLAMBDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
110 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, DLAMBDA( K+1 ), 1, D( K+1 ), 1 )
CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1,
$ K+1 ),
$ LDQ )
END IF
*
RETURN
*
* End of ZLAED8
*
END
*> \brief \b ZLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAGTM + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlagtm.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlagtm.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlagtm.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
* B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER LDB, LDX, N, NRHS
* DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ),
* $ X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAGTM performs a matrix-matrix product of the form
*>
*> B := alpha * A * X + beta * B
*>
*> where A is a tridiagonal matrix of order N, B and X are N by NRHS
*> matrices, and alpha and beta are real scalars, each of which may be
*> 0., 1., or -1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the operation applied to A.
*> = 'N': No transpose, B := alpha * A * X + beta * B
*> = 'T': Transpose, B := alpha * A**T * X + beta * B
*> = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B
*> \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 matrices X and B.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION
*> The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
*> it is assumed to be 0.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) sub-diagonal elements of T.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The diagonal elements of T.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) super-diagonal elements of T.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> The N by NRHS matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(N,1).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION
*> The scalar beta. BETA must be 0., 1., or -1.; otherwise,
*> it is assumed to be 1.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N by NRHS matrix B.
*> On exit, B is overwritten by the matrix expression
*> B := alpha * A * X + beta * B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(N,1).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lagtm
*
* =====================================================================
SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX,
$ BETA,
$ B, LDB )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER LDB, LDX, N, NRHS
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ),
$ X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 )
$ RETURN
*
* Multiply B by BETA if BETA.NE.1.
*
IF( BETA.EQ.ZERO ) THEN
DO 20 J = 1, NRHS
DO 10 I = 1, N
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE IF( BETA.EQ.-ONE ) THEN
DO 40 J = 1, NRHS
DO 30 I = 1, N
B( I, J ) = -B( I, J )
30 CONTINUE
40 CONTINUE
END IF
*
IF( ALPHA.EQ.ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B + A*X
*
DO 60 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 50 I = 2, N - 1
B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DU( I )*X( I+1, J )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Compute B := B + A**T * X
*
DO 80 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
$ D( N )*X( N, J )
DO 70 I = 2, N - 1
B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
$ D( I )*X( I, J ) + DL( I )*X( I+1, J )
70 CONTINUE
END IF
80 CONTINUE
ELSE IF( LSAME( TRANS, 'C' ) ) THEN
*
* Compute B := B + A**H * X
*
DO 100 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) + DCONJG( D( 1 ) )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) + DCONJG( D( 1 ) )*X( 1, J ) +
$ DCONJG( DL( 1 ) )*X( 2, J )
B( N, J ) = B( N, J ) + DCONJG( DU( N-1 ) )*
$ X( N-1, J ) + DCONJG( D( N ) )*X( N, J )
DO 90 I = 2, N - 1
B( I, J ) = B( I, J ) + DCONJG( DU( I-1 ) )*
$ X( I-1, J ) + DCONJG( D( I ) )*
$ X( I, J ) + DCONJG( DL( I ) )*
$ X( I+1, J )
90 CONTINUE
END IF
100 CONTINUE
END IF
ELSE IF( ALPHA.EQ.-ONE ) THEN
IF( LSAME( TRANS, 'N' ) ) THEN
*
* Compute B := B - A*X
*
DO 120 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DU( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 110 I = 2, N - 1
B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DU( I )*X( I+1, J )
110 CONTINUE
END IF
120 CONTINUE
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Compute B := B - A**T *X
*
DO 140 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
$ DL( 1 )*X( 2, J )
B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
$ D( N )*X( N, J )
DO 130 I = 2, N - 1
B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
$ D( I )*X( I, J ) - DL( I )*X( I+1, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( TRANS, 'C' ) ) THEN
*
* Compute B := B - A**H *X
*
DO 160 J = 1, NRHS
IF( N.EQ.1 ) THEN
B( 1, J ) = B( 1, J ) - DCONJG( D( 1 ) )*X( 1, J )
ELSE
B( 1, J ) = B( 1, J ) - DCONJG( D( 1 ) )*X( 1, J ) -
$ DCONJG( DL( 1 ) )*X( 2, J )
B( N, J ) = B( N, J ) - DCONJG( DU( N-1 ) )*
$ X( N-1, J ) - DCONJG( D( N ) )*X( N, J )
DO 150 I = 2, N - 1
B( I, J ) = B( I, J ) - DCONJG( DU( I-1 ) )*
$ X( I-1, J ) - DCONJG( D( I ) )*
$ X( I, J ) - DCONJG( DL( I ) )*
$ X( I+1, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
END IF
RETURN
*
* End of ZLAGTM
*
END
*> \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHEF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahef.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahef.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahef.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHEF computes a partial factorization of a complex Hermitian
*> matrix A using the Bunch-Kaufman diagonal pivoting method. The
*> partial factorization has the form:
*>
*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
*>
*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L'
*> ( L21 I ) ( 0 A22 ) ( 0 I )
*>
*> where the order of D is at most NB. The actual order is returned in
*> the argument KB, and is either NB or NB-1, or N if N <= NB.
*> Note that U**H denotes the conjugate transpose of U.
*>
*> ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
*> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
*> A22 (if UPLO = 'L').
*> \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] NB
*> \verbatim
*> NB is INTEGER
*> The maximum number of columns of the matrix A that should be
*> factored. NB should be at least 2 to allow for 2-by-2 pivot
*> blocks.
*> \endverbatim
*>
*> \param[out] KB
*> \verbatim
*> KB is INTEGER
*> The number of columns of A that were actually factored.
*> KB is either NB-1 or NB, or N if N <= NB.
*> \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, A contains details of the partial factorization.
*> \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)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (LDW,NB)
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lahef
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> December 2016, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*> \endverbatim
*
* =====================================================================
SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP,
$ KSTEP, KW
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T
COMPLEX*16 D11, D21, D22, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
EXTERNAL LSAME, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV,
$ ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11 (note that conjg(W) is actually stored)
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
KSTEP = 1
*
* Copy column K of A to column KW of W and update it
*
CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
W( K, KW ) = DBLE( A( K, K ) )
IF( K.LT.N ) THEN
CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
$ LDA,
$ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
W( K, KW ) = DBLE( W( K, KW ) )
END IF
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( W( K, KW ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
COLMAX = CABS1( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* BEGIN pivot search along IMAX row
*
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) )
CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
IF( K.LT.N ) THEN
CALL ZGEMV( 'No transpose', K, N-K, -CONE,
$ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
$ CONE, W( 1, KW-1 ), 1 )
W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) )
END IF
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
END IF
*
* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
* Case(3)
ELSE IF( ABS( DBLE( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW of W
*
CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
*
* Case(4)
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
*
*
* END pivot search along IMAX row
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K-1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = DBLE( A( KK, KK ) )
CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
IF( KP.GT.1 )
$ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last K+1 to N columns of A
* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in last KKW to NB columns of W.
*
IF( K.LT.N )
$ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column kw of W now holds
*
* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
* (1) Store subdiag. elements of column U(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element U(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,kw)
* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
* (NOTE: No need to use for Hermitian matrix
* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
* element D(k,k) from W (potentially saves only one load))
CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
IF( K.GT.1 ) THEN
*
* (NOTE: No need to check if A(k,k) is NOT ZERO,
* since that was ensured earlier in pivot search:
* case A(k,k) = 0 falls into 2x2 pivot case(4))
*
R1 = ONE / DBLE( A( K, K ) )
CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
*
* (2) Conjugate column W(kw)
*
CALL ZLACGV( K-1, W( 1, KW ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
* block D(k-1:k,k-1:k) in columns k-1 and k of A.
* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
* block and not stored)
* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
* Factor out the columns of the inverse of 2-by-2 pivot
* block D, so that each column contains 1, to reduce the
* number of FLOPS when we multiply panel
* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
*
* D**(-1) = ( d11 cj(d21) )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
* ( (-d21) ( d11 ) )
*
* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
*
* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
* ( ( -1 ) ( d11/conj(d21) ) )
*
* = 1/(|d21|**2) * 1/(D22*D11-1) *
*
* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( conj(D21)*( D11 ) D21*( -1 ) )
* ( ( -1 ) ( D22 ) ),
*
* where D11 = d22/d21,
* D22 = d11/conj(d21),
* D21 = T/d21,
* T = 1/(D22*D11-1).
*
* (NOTE: No need to check for division by ZERO,
* since that was ensured earlier in pivot search:
* (a) d21 != 0, since in 2x2 pivot case(4)
* |d21| should be larger than |d11| and |d22|;
* (b) (D22*D11 - 1) != 0, since from (a),
* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / DCONJG( D21 )
D22 = W( K-1, KW-1 ) / D21
T = ONE / ( DBLE( D11*D22 )-ONE )
D21 = T / D21
*
* Update elements in columns A(k-1) and A(k) as
* dot products of rows of ( W(kw-1) W(kw) ) and columns
* of D**(-1)
*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = DCONJG( D21 )*
$ ( D22*W( J, KW )-W( J, KW-1 ) )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
* (2) Conjugate columns W(kw) and W(kw-1)
*
CALL ZLACGV( K-1, W( 1, KW ), 1 )
CALL ZLACGV( K-2, W( 1, KW-1 ), 1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
*
* (note that conjg(W) is actually stored)
*
CALL ZGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K,
$ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW,
$ CONE, A( 1, 1 ), LDA )
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J + 1
END IF
* (NOTE: Here, J is used to determine row length. Length N-J+1
* of the rows to swap back doesn't include diagonal element)
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22 (note that conjg(W) is actually stored)
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
KSTEP = 1
*
* Copy column K of A to column K of W and update it
*
W( K, K ) = DBLE( A( K, K ) )
IF( K.LT.N )
$ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
$ LDA,
$ W( K, 1 ), LDW, CONE, W( K, K ), 1 )
W( K, K ) = DBLE( W( K, K ) )
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = ABS( DBLE( W( K, K ) ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
COLMAX = CABS1( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
A( K, K ) = DBLE( A( K, K ) )
ELSE
*
* ============================================================
*
* BEGIN pivot search
*
* Case(1)
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* BEGIN pivot search along IMAX row
*
*
* Copy column IMAX to column K+1 of W and update it
*
CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ),
$ 1 )
CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 )
W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) )
IF( IMAX.LT.N )
$ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
$ W( IMAX+1, K+1 ), 1 )
CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K,
$ 1 ),
$ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
$ 1 )
W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value.
* Determine only ROWMAX.
*
JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
END IF
*
* Case(2)
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
*
* Case(3)
ELSE IF( ABS( DBLE( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX )
$ THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K of W
*
CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
*
* Case(4)
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
*
*
* END pivot search along IMAX row
*
END IF
*
* END pivot search
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K+1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = DBLE( A( KK, KK ) )
CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
IF( KP.LT.N )
$ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ),
$ 1 )
*
* Interchange rows KK and KP in first K-1 columns of A
* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in first KK columns of W.
*
IF( K.GT.1 )
$ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
* (1) Store subdiag. elements of column L(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element L(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,k)
* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
* (NOTE: No need to use for Hermitian matrix
* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
* element D(k,k) from W (potentially saves only one load))
CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
*
* (NOTE: No need to check if A(k,k) is NOT ZERO,
* since that was ensured earlier in pivot search:
* case A(k,k) = 0 falls into 2x2 pivot case(4))
*
R1 = ONE / DBLE( A( K, K ) )
CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
*
* (2) Conjugate column W(k)
*
CALL ZLACGV( N-K, W( K+1, K ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
* block D(k:k+1,k:k+1) in columns k and k+1 of A.
* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
* block and not stored)
* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
* Factor out the columns of the inverse of 2-by-2 pivot
* block D, so that each column contains 1, to reduce the
* number of FLOPS when we multiply panel
* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
*
* D**(-1) = ( d11 cj(d21) )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
* ( (-d21) ( d11 ) )
*
* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
*
* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
* ( ( -1 ) ( d11/conj(d21) ) )
*
* = 1/(|d21|**2) * 1/(D22*D11-1) *
*
* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = ( conj(D21)*( D11 ) D21*( -1 ) )
* ( ( -1 ) ( D22 ) ),
*
* where D11 = d22/d21,
* D22 = d11/conj(d21),
* D21 = T/d21,
* T = 1/(D22*D11-1).
*
* (NOTE: No need to check for division by ZERO,
* since that was ensured earlier in pivot search:
* (a) d21 != 0, since in 2x2 pivot case(4)
* |d21| should be larger than |d11| and |d22|;
* (b) (D22*D11 - 1) != 0, since from (a),
* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / DCONJG( D21 )
T = ONE / ( DBLE( D11*D22 )-ONE )
D21 = T / D21
*
* Update elements in columns A(k) and A(k+1) as
* dot products of rows of ( W(k) W(k+1) ) and columns
* of D**(-1)
*
DO 80 J = K + 2, N
A( J, K ) = DCONJG( D21 )*
$ ( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
* (2) Conjugate columns W(k) and W(k+1)
*
CALL ZLACGV( N-K, W( K+1, K ), 1 )
CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
*
* (note that conjg(W) is actually stored)
*
CALL ZGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1,
$ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW,
$ CONE, A( K, K ), LDA )
*
* Put L21 in standard form by partially undoing the interchanges
* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J - 1
END IF
* (NOTE: Here, J is used to determine row length. Length J
* of the rows to swap back doesn't include diagonal element)
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of ZLAHEF
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahqr.f">
*> [TXT]</a>
*> \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
*> > 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 > 0 and WANTT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the
*> eigenvalues of the upper Hessenberg matrix
*> rows and columns ILO through INFO of the final,
*> output value of H.
*>
*> If INFO > 0 and WANTT is .TRUE., then on exit
*> (*) (initial value of H)*U = U*(final value of H)
*> where U is an orthogonal matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO > 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.
*
*> \ingroup lahqr
*
*> \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 )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
* =========================================================
*
* .. Parameters ..
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 )
INTEGER KEXSH
PARAMETER ( KEXSH = 10 )
* ..
* .. 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, ITMAX, J, JHI, JLO, K, L, M,
$ NH, NZ, KDEFL
* ..
* .. Local Arrays ..
COMPLEX*16 V( 2 )
* ..
* .. External Functions ..
COMPLEX*16 ZLADIV
DOUBLE PRECISION DLAMCH
EXTERNAL ZLADIV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL 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
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
*
* ITMAX is the total number of QR iterations allowed.
*
ITMAX = 30 * MAX( 10, NH )
*
* KDEFL counts the number of iterations since a deflation
*
KDEFL = 0
*
* 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
KDEFL = KDEFL + 1
*
* 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( MOD(KDEFL,2*KEXSH).EQ.0 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
T = S + H( I, I )
ELSE IF( MOD(KDEFL,KEXSH).EQ.0 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( L+1, L ) ) )
T = S + H( L, L )
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 )
* reset deflation counter
KDEFL = 0
*
* 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahr2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahr2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahr2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lahr2
*
*> \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 ZLAHRD
*> 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 ZLAHRD routine. (This
*> subroutine is not backward compatible with LAPACK-3.0's ZLAHRD.)
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahrd.f">
*> [TXT]</a>
*> \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
*>
*> This routine is deprecated and has been replaced by routine ZLAHR2.
*>
*> 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.
*> \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.
*
*> \ingroup lahrd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlals0.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlals0.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlals0.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lals0
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
N = NL + NR + 1
*
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
ELSE 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
*
* Use calls to the subroutine DLAMC3 to enforce the
* parentheses (x+y)+z. The goal is to prevent
* optimizing compilers from doing x+(y+z).
*
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
*
* Use calls to the subroutine DLAMC3 to enforce the
* parentheses (x+y)+z. The goal is to prevent
* optimizing compilers from doing x+(y+z).
*
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
*> \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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlalsa.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlalsa.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlalsa.f">
*> [TXT]</a>
*> \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 intermediate 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 orthogonal
*> 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, dimension (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.
*
*> \ingroup lalsa
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlalsd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlalsd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlalsd.f">
*> [TXT]</a>
*> \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.
*>
*> \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 (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.
*
*> \ingroup lalsd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of general band matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANGB + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlangb.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlangb.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlangb.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB,
* WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER KL, KU, LDAB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANGB returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of an
*> n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
*> \endverbatim
*>
*> \return ZLANGB
*> \verbatim
*>
*> ZLANGB = ( 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 ZLANGB as described
*> above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANGB is
*> set to zero.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of sub-diagonals of the matrix A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of super-diagonals of the matrix A. KU >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The band matrix A, stored in rows 1 to KL+KU+1. The j-th
*> column of A is stored in the j-th column of the array AB as
*> follows:
*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KL+KU+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.
*
*> \ingroup langb
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB,
$ WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER KL, KU, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K, L
DOUBLE PRECISION SCALE, SUM, VALUE, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
TEMP = ABS( AB( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
SUM = SUM + ABS( AB( 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
K = KU + 1 - J
DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, N
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
L = MAX( 1, J-KU )
K = KU + 1 - J + L
CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE,
$ SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANGB = VALUE
RETURN
*
* End of ZLANGB
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlange.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlange.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlange.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lange
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANGT + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlangt.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlangt.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlangt.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER N
* ..
* .. Array Arguments ..
* COMPLEX*16 D( * ), DL( * ), DU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANGT 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 tridiagonal matrix A.
*> \endverbatim
*>
*> \return ZLANGT
*> \verbatim
*>
*> ZLANGT = ( 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 ZLANGT as described
*> above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANGT is
*> set to zero.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*> DL is COMPLEX*16 array, dimension (N-1)
*> The (n-1) sub-diagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (N)
*> The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*> DU is COMPLEX*16 array, dimension (N-1)
*> The (n-1) super-diagonal elements of A.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup langt
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
COMPLEX*16 D( * ), DL( * ), DU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
IF( ANORM.LT.ABS( DL( I ) ) .OR.
$ DISNAN( ABS( DL( I ) ) ) )
$ ANORM = ABS(DL(I))
IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) )
$ ANORM = ABS(D(I))
IF( ANORM.LT.ABS( DU( I ) ) .OR.
$ DISNAN (ABS( DU( I ) ) ) )
$ ANORM = ABS(DU(I))
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) )
TEMP = ABS( D( N ) )+ABS( DU( N-1 ) )
IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP
DO 20 I = 2, N - 1
TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) )
IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP
20 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) )
TEMP = ABS( D( N ) )+ABS( DL( N-1 ) )
IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP
DO 30 I = 2, N - 1
TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) )
IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP
30 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR.
$ ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
CALL ZLASSQ( N, D, 1, SCALE, SUM )
IF( N.GT.1 ) THEN
CALL ZLASSQ( N-1, DL, 1, SCALE, SUM )
CALL ZLASSQ( N-1, DU, 1, SCALE, SUM )
END IF
ANORM = SCALE*SQRT( SUM )
END IF
*
ZLANGT = ANORM
RETURN
*
* End of ZLANGT
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhe.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhe.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhe.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lanhe
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZLANHP 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 supplied in packed form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHP + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhp.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhp.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhp.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHP 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, supplied in packed form.
*> \endverbatim
*>
*> \return ZLANHP
*> \verbatim
*>
*> ZLANHP = ( 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 ZLANHP 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 supplied.
*> = 'U': Upper triangular part of A is supplied
*> = 'L': Lower triangular part of A is supplied
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHP is
*> set to zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangle of the hermitian matrix A, packed
*> columnwise in a linear array. The j-th column of A is stored
*> in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \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.
*
*> \ingroup lanhp
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
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
K = 0
DO 20 J = 1, N
DO 10 I = K + 1, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = K + 1, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
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
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AP( K ) ) )
K = K + 1
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( AP( K ) ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
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
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHP = VALUE
RETURN
*
* End of ZLANHP
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlanhs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlanhs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlanhs.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lanhs
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANSP + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlansp.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlansp.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlansp.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANSP 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 symmetric matrix A, supplied in packed form.
*> \endverbatim
*>
*> \return ZLANSP
*> \verbatim
*>
*> ZLANSP = ( 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 ZLANSP as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is supplied.
*> = 'U': Upper triangular part of A is supplied
*> = 'L': Lower triangular part of A is supplied
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANSP is
*> set to zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangle of the symmetric matrix A, packed
*> columnwise in a linear array. The j-th column of A is stored
*> in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> \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.
*
*> \ingroup lanhp
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, 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
K = 1
DO 20 J = 1, N
DO 10 I = K, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
DO 30 I = K, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
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 symmetric).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( AP( K ) )
K = K + 1
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( AP( K ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
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
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( DIMAG( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DIMAG( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANSP = VALUE
RETURN
*
* End of ZLANSP
*
END
*> \brief \b ZLANSY 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 symmetric matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANSY + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlansy.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlansy.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlansy.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANSY( 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
*>
*> ZLANSY 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 symmetric matrix A.
*> \endverbatim
*>
*> \return ZLANSY
*> \verbatim
*>
*> ZLANSY = ( 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 ZLANSY as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric 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, ZLANSY is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The symmetric 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.
*> \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.
*
*> \ingroup lanhe
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, 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
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, 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 symmetric).
*
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( 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( 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
CALL ZLASSQ( N, A, LDA+1, SCALE, SUM )
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANSY = VALUE
RETURN
*
* End of ZLANSY
*
END
*> \brief \b ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANTB + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlantb.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlantb.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlantb.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB,
* LDAB, WORK )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORM, UPLO
* INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANTB returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of an
*> n by n triangular band matrix A, with ( k + 1 ) diagonals.
*> \endverbatim
*>
*> \return ZLANTB
*> \verbatim
*>
*> ZLANTB = ( 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 ZLANTB as described
*> above.
*> \endverbatim
*>
*> \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] 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] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANTB is
*> set to zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of super-diagonals of the matrix A if UPLO = 'U',
*> or the number of sub-diagonals of the matrix A if UPLO = 'L'.
*> K >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The upper or lower triangular band matrix A, stored in the
*> first k+1 rows of AB. The j-th column of A is stored
*> in the j-th column of the array AB as follows:
*> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
*> Note that when DIAG = 'U', the elements of the array AB
*> corresponding to the diagonal elements of the matrix A are
*> not referenced, but are assumed to be one.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= K+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.
*
*> \ingroup lantb
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB,
$ LDAB, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER K, LDAB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, L
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( 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 = MAX( K+2-J, 1 ), K
SUM = ABS( AB( I, J ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = 2, MIN( N+1-J, K+1 )
SUM = ABS( AB( 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 = MAX( K+2-J, 1 ), K + 1
SUM = ABS( AB( I, J ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = 1, MIN( N+1-J, K+1 )
SUM = ABS( AB( 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 ) THEN
SUM = ONE
DO 90 I = MAX( K+2-J, 1 ), K
SUM = SUM + ABS( AB( I, J ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = MAX( K+2-J, 1 ), K + 1
SUM = SUM + ABS( AB( 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 = 2, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( I, J ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = 1, MIN( N+1-J, K+1 )
SUM = SUM + ABS( AB( 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).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
L = K + 1 - J
DO 160 I = MAX( 1, J-K ), J - 1
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
160 CONTINUE
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
L = K + 1 - J
DO 190 I = MAX( 1, J-K ), J
WORK( I ) = WORK( I ) + ABS( AB( L+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 230 J = 1, N
L = 1 - J
DO 220 I = J + 1, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
L = 1 - J
DO 250 I = J, MIN( N, J+K )
WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
250 CONTINUE
260 CONTINUE
END IF
END IF
DO 270 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
270 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 = N
IF( K.GT.0 ) THEN
DO 280 J = 2, N
CALL ZLASSQ( MIN( J-1, K ),
$ AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
$ SUM )
280 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 290 J = 1, N
CALL ZLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ),
$ J ),
$ 1, SCALE, SUM )
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
IF( K.GT.0 ) THEN
DO 300 J = 1, N - 1
CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1,
$ SCALE,
$ SUM )
300 CONTINUE
END IF
ELSE
SCALE = ZERO
SUM = ONE
DO 310 J = 1, N
CALL ZLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1,
$ SCALE,
$ SUM )
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANTB = VALUE
RETURN
*
* End of ZLANTB
*
END
*> \brief \b ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANTP + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlantp.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlantp.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlantp.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORM, UPLO
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANTP returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> triangular matrix A, supplied in packed form.
*> \endverbatim
*>
*> \return ZLANTP
*> \verbatim
*>
*> ZLANTP = ( 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 ZLANTP as described
*> above.
*> \endverbatim
*>
*> \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] 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] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANTP is
*> set to zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangular matrix A, packed columnwise in
*> a linear array. The j-th column of A is stored in the array
*> AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> Note that when DIAG = 'U', the elements of the array AP
*> corresponding to the diagonal elements of the matrix A are
*> not referenced, but are assumed to be one.
*> \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.
*
*> \ingroup lantp
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP,
$ WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UDIAG
INTEGER I, J, K
DOUBLE PRECISION SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
K = 1
IF( LSAME( DIAG, 'U' ) ) THEN
VALUE = ONE
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = K, K + J - 2
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = K + 1, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
DO 50 I = K, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
50 CONTINUE
K = K + J
60 CONTINUE
ELSE
DO 80 J = 1, N
DO 70 I = K, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR.
$ DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
K = K + N - J + 1
80 CONTINUE
END IF
END IF
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
K = 1
UDIAG = LSAME( DIAG, 'U' )
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 1, N
IF( UDIAG ) THEN
SUM = ONE
DO 90 I = K, K + J - 2
SUM = SUM + ABS( AP( I ) )
90 CONTINUE
ELSE
SUM = ZERO
DO 100 I = K, K + J - 1
SUM = SUM + ABS( AP( I ) )
100 CONTINUE
END IF
K = K + J
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 = K + 1, K + N - J
SUM = SUM + ABS( AP( I ) )
120 CONTINUE
ELSE
SUM = ZERO
DO 130 I = K, K + N - J
SUM = SUM + ABS( AP( I ) )
130 CONTINUE
END IF
K = K + N - J + 1
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
140 CONTINUE
END IF
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
IF( LSAME( DIAG, 'U' ) ) THEN
DO 150 I = 1, N
WORK( I ) = ONE
150 CONTINUE
DO 170 J = 1, N
DO 160 I = 1, J - 1
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
160 CONTINUE
K = K + 1
170 CONTINUE
ELSE
DO 180 I = 1, N
WORK( I ) = ZERO
180 CONTINUE
DO 200 J = 1, N
DO 190 I = 1, J
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
190 CONTINUE
200 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
DO 210 I = 1, N
WORK( I ) = ONE
210 CONTINUE
DO 230 J = 1, N
K = K + 1
DO 220 I = J + 1, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
220 CONTINUE
230 CONTINUE
ELSE
DO 240 I = 1, N
WORK( I ) = ZERO
240 CONTINUE
DO 260 J = 1, N
DO 250 I = J, N
WORK( I ) = WORK( I ) + ABS( AP( K ) )
K = K + 1
250 CONTINUE
260 CONTINUE
END IF
END IF
VALUE = ZERO
DO 270 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
270 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 = N
K = 2
DO 280 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
280 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 290 J = 1, N
CALL ZLASSQ( J, AP( K ), 1, SCALE, SUM )
K = K + J
290 CONTINUE
END IF
ELSE
IF( LSAME( DIAG, 'U' ) ) THEN
SCALE = ONE
SUM = N
K = 2
DO 300 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
300 CONTINUE
ELSE
SCALE = ZERO
SUM = ONE
K = 1
DO 310 J = 1, N
CALL ZLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
310 CONTINUE
END IF
END IF
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANTP = VALUE
RETURN
*
* End of ZLANTP
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlantr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlantr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlantr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lantr
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A,
$ LDA,
$ WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, MIN( M, 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 ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQGB + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqgb.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqgb.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqgb.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
* AMAX, EQUED )
*
* .. Scalar Arguments ..
* CHARACTER EQUED
* INTEGER KL, KU, LDAB, M, N
* DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), R( * )
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQGB equilibrates a general M by N band matrix A with KL
*> subdiagonals and KU superdiagonals using the row and scaling factors
*> in the vectors R and C.
*> \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] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
*> The j-th column of A is stored in the j-th column of the
*> array AB as follows:
*> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*> On exit, the equilibrated matrix, in the same storage format
*> as A. See EQUED for the form of the equilibrated matrix.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDA >= KL+KU+1.
*> \endverbatim
*>
*> \param[in] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (M)
*> The row scale factors for A.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> The column scale factors for A.
*> \endverbatim
*>
*> \param[in] ROWCND
*> \verbatim
*> ROWCND is DOUBLE PRECISION
*> Ratio of the smallest R(i) to the largest R(i).
*> \endverbatim
*>
*> \param[in] COLCND
*> \verbatim
*> COLCND is DOUBLE PRECISION
*> Ratio of the smallest C(i) to the largest C(i).
*> \endverbatim
*>
*> \param[in] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix entry.
*> \endverbatim
*>
*> \param[out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies the form of equilibration that was done.
*> = 'N': No equilibration
*> = 'R': Row equilibration, i.e., A has been premultiplied by
*> diag(R).
*> = 'C': Column equilibration, i.e., A has been postmultiplied
*> by diag(C).
*> = 'B': Both row and column equilibration, i.e., A has been
*> replaced by diag(R) * A * diag(C).
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> THRESH is a threshold value used to decide if row or column scaling
*> should be done based on the ratio of the row or column scaling
*> factors. If ROWCND < THRESH, row scaling is done, and if
*> COLCND < THRESH, column scaling is done.
*>
*> LARGE and SMALL are threshold values used to decide if row scaling
*> should be done based on the absolute size of the largest matrix
*> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laqgb
*
* =====================================================================
SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND,
$ COLCND,
$ AMAX, EQUED )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER KL, KU, LDAB, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), R( * )
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of ZLAQGB
*
END
*> \brief \b ZLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQGE + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqge.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqge.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqge.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
* EQUED )
*
* .. Scalar Arguments ..
* CHARACTER EQUED
* INTEGER LDA, M, N
* DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), R( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQGE equilibrates a general M by N matrix A using the row and
*> column scaling factors in the vectors R and C.
*> \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 equilibrated matrix. See EQUED for the form of
*> the equilibrated matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(M,1).
*> \endverbatim
*>
*> \param[in] R
*> \verbatim
*> R is DOUBLE PRECISION array, dimension (M)
*> The row scale factors for A.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N)
*> The column scale factors for A.
*> \endverbatim
*>
*> \param[in] ROWCND
*> \verbatim
*> ROWCND is DOUBLE PRECISION
*> Ratio of the smallest R(i) to the largest R(i).
*> \endverbatim
*>
*> \param[in] COLCND
*> \verbatim
*> COLCND is DOUBLE PRECISION
*> Ratio of the smallest C(i) to the largest C(i).
*> \endverbatim
*>
*> \param[in] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix entry.
*> \endverbatim
*>
*> \param[out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies the form of equilibration that was done.
*> = 'N': No equilibration
*> = 'R': Row equilibration, i.e., A has been premultiplied by
*> diag(R).
*> = 'C': Column equilibration, i.e., A has been postmultiplied
*> by diag(C).
*> = 'B': Both row and column equilibration, i.e., A has been
*> replaced by diag(R) * A * diag(C).
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> THRESH is a threshold value used to decide if row or column scaling
*> should be done based on the ratio of the row or column scaling
*> factors. If ROWCND < THRESH, row scaling is done, and if
*> COLCND < THRESH, column scaling is done.
*>
*> LARGE and SMALL are threshold values used to decide if row scaling
*> should be done based on the absolute size of the largest matrix
*> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laqge
*
* =====================================================================
SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
$ EQUED )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED
INTEGER LDA, M, N
DOUBLE PRECISION AMAX, COLCND, ROWCND
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), R( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
$ THEN
*
* No row scaling
*
IF( COLCND.GE.THRESH ) THEN
*
* No column scaling
*
EQUED = 'N'
ELSE
*
* Column scaling
*
DO 20 J = 1, N
CJ = C( J )
DO 10 I = 1, M
A( I, J ) = CJ*A( I, J )
10 CONTINUE
20 CONTINUE
EQUED = 'C'
END IF
ELSE IF( COLCND.GE.THRESH ) THEN
*
* Row scaling, no column scaling
*
DO 40 J = 1, N
DO 30 I = 1, M
A( I, J ) = R( I )*A( I, J )
30 CONTINUE
40 CONTINUE
EQUED = 'R'
ELSE
*
* Row and column scaling
*
DO 60 J = 1, N
CJ = C( J )
DO 50 I = 1, M
A( I, J ) = CJ*R( I )*A( I, J )
50 CONTINUE
60 CONTINUE
EQUED = 'B'
END IF
*
RETURN
*
* End of ZLAQGE
*
END
*> \brief \b ZLAQHE scales a Hermitian matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQHE + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqhe.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqhe.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqhe.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
*
* .. Scalar Arguments ..
* CHARACTER EQUED, UPLO
* INTEGER LDA, N
* DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION S( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQHE equilibrates a Hermitian matrix A using the scaling factors
*> in the vector S.
*> \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 EQUED = 'Y', the equilibrated matrix:
*> diag(S) * A * diag(S).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(N,1).
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (N)
*> The scale factors for A.
*> \endverbatim
*>
*> \param[in] SCOND
*> \verbatim
*> SCOND is DOUBLE PRECISION
*> Ratio of the smallest S(i) to the largest S(i).
*> \endverbatim
*>
*> \param[in] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix entry.
*> \endverbatim
*>
*> \param[out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies whether or not equilibration was done.
*> = 'N': No equilibration.
*> = 'Y': Equilibration was done, i.e., A has been replaced by
*> diag(S) * A * diag(S).
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> THRESH is a threshold value used to decide if scaling should be done
*> based on the ratio of the scaling factors. If SCOND < THRESH,
*> scaling is done.
*>
*> LARGE and SMALL are threshold values used to decide if scaling should
*> be done based on the absolute size of the largest matrix element.
*> If AMAX > LARGE or AMAX < SMALL, scaling is done.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laqhe
*
* =====================================================================
SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED, UPLO
INTEGER LDA, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, THRESH
PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION CJ, LARGE, SMALL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
EQUED = 'N'
RETURN
END IF
*
* Initialize LARGE and SMALL.
*
SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
LARGE = ONE / SMALL
*
IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
* No equilibration
*
EQUED = 'N'
ELSE
*
* Replace A by diag(S) * A * diag(S).
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Upper triangle of A is stored.
*
DO 20 J = 1, N
CJ = S( J )
DO 10 I = 1, J - 1
A( I, J ) = CJ*S( I )*A( I, J )
10 CONTINUE
A( J, J ) = CJ*CJ*DBLE( A( J, J ) )
20 CONTINUE
ELSE
*
* Lower triangle of A is stored.
*
DO 40 J = 1, N
CJ = S( J )
A( J, J ) = CJ*CJ*DBLE( A( J, J ) )
DO 30 I = J + 1, N
A( I, J ) = CJ*S( I )*A( I, J )
30 CONTINUE
40 CONTINUE
END IF
EQUED = 'Y'
END IF
*
RETURN
*
* End of ZLAQHE
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup laqp2
*
*> \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
*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">[PDF]</a>
*> \endhtmlonly
*
* =====================================================================
SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
$ WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
* ..
* .. External Subroutines ..
EXTERNAL ZLARF1F, 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.
*
CALL ZLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
$ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
$ WORK( 1 ) )
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqps.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqps.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqps.f">
*> [TXT]</a>
*> \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)
*> Auxiliary 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.
*
*> \ingroup laqps
*
*> \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
*> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">[PDF]</a>
*> \endhtmlonly
*
* =====================================================================
SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU,
$ VN1,
$ VN2, AUXV, F, LDF )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr0.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr0.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr0.f">
*> [TXT]</a>
*> \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 >= 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 > 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 > 0, then 1 <= ILO <= IHI <= 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 > 0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i > 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 >= 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 <= ILOZ <= ILO; IHI <= IHIZ <= 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 > 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 >= MAX(1,IHIZ). Otherwise, LDZ >= 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 >= 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
*> > 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 > 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 > 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 > 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 > 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.
*
*> \ingroup laqr0
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 = 15 )
*
* ==== 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 = 15, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.4.) ====
*
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 = 15, 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-3 ) / 6, 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-3 ) / 6, 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-3)/6,
* . 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 magnitude
* . 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 = 2*NS
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr1.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr1.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr1.f">
*> [TXT]</a>
*> \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, 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 >= 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, 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.
*
*> \ingroup laqr1
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ..
*
* Quick return if possible
*
IF( N.NE.2 .AND. N.NE.3 ) THEN
RETURN
END IF
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr2.f">
*> [TXT]</a>
*> \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 <= NW <= (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 <= 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 <= ILOZ <= IHIZ <= 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,ILOZ:IHIZ) 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 <= 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
*> The leading dimension of V just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH >= 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 <= LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV >= 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 <= 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.
*
*> \ingroup laqr2
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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 ZCOPY, ZGEHRD, ZGEMM, ZLACPY,
$ ZLAHQR,
$ ZLARF1F, 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
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
CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
$ LDT )
*
CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF1F( '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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr3.f">
*> [TXT]</a>
*> \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 <= NW <= (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 <= 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 <= ILOZ <= IHIZ <= 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,ILOZ:IHIZ) 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 <= 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
*> The leading dimension of V just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH >= 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 <= LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV >= 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 <= 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.
*
*> \ingroup laqr3
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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 ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
$ ZLAQR4,
$ ZLARF1F, 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
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
CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU )
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ),
$ LDT )
*
CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF1F( '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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr4.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr4.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr4.f">
*> [TXT]</a>
*> \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 >= 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 > 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 > 0, then 1 <= ILO <= IHI <= 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 > 0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i > 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 >= 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 <= ILOZ <= ILO; IHI <= IHIZ <= 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 > 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 >= MAX(1,IHIZ). Otherwise, LDZ >= 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 >= 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
*> > 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 > 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 > 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 > 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 > 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.
*
*> \ingroup laqr4
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 = 15 )
*
* ==== 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 = 15, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.4.) ====
*
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 = 15, 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-3 ) / 6, 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-3 ) / 6, 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-3)/6,
* . 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 magnitude
* . 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 = 2*NS
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqr5.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqr5.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqr5.f">
*> [TXT]</a>
*> \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
*> WANTT = .true. if the triangular Schur factor
*> is being computed. WANTT is set to .false. otherwise.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> 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: Same as KACC22 = 1. This option used to enable exploiting
*> the 2-by-2 structure during matrix multiplications, but
*> this is no longer supported.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> N is the order of the Hessenberg matrix H upon which this
*> subroutine operates.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> 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
*> NSHFTS gives the number of simultaneous shifts. NSHFTS
*> must be positive and even.
*> \endverbatim
*>
*> \param[in,out] S
*> \verbatim
*> S is COMPLEX*16 array, dimension (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, dimension (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
*> LDH is the leading dimension of H just as declared in the
*> calling procedure. LDH >= 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 <= ILOZ <= IHIZ <= N
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHIZ)
*> If WANTZ = .TRUE., then the QR Sweep unitary
*> similarity transformation is accumulated into
*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
*> If WANTZ = .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> LDA is the leading dimension of Z just as declared in
*> the calling procedure. LDZ >= N.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NSHFTS/2)
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> LDV is the leading dimension of V as declared in the
*> calling procedure. LDV >= 3.
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*> U is COMPLEX*16 array, dimension (LDU,2*NSHFTS)
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> LDU is the leading dimension of U just as declared in the
*> in the calling subroutine. LDU >= 2*NSHFTS.
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> NV is the number of rows in WV agailable for workspace.
*> NV >= 1.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,2*NSHFTS)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> LDWV is the leading dimension of WV as declared in the
*> in the calling subroutine. LDWV >= NV.
*> \endverbatim
*
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> NH is the number of columns in array WH available for
*> workspace. NH >= 1.
*> \endverbatim
*>
*> \param[out] WH
*> \verbatim
*> WH is COMPLEX*16 array, dimension (LDWH,NH)
*> \endverbatim
*>
*> \param[in] LDWH
*> \verbatim
*> LDWH is INTEGER
*> Leading dimension of WH just as declared in the
*> calling procedure. LDWH >= 2*NSHFTS.
*> \endverbatim
*>
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laqr5
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
*> Lars Karlsson, Daniel Kressner, and Bruno Lang
*>
*> Thijs Steel, Department of Computer science,
*> KU Leuven, Belgium
*
*> \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.
*>
*> Lars Karlsson, Daniel Kressner, and Bruno Lang, Optimally packed
*> chains of bulges in multishift QR algorithms.
*> ACM Trans. Math. Softw. 40, 2, Article 12 (February 2014).
*>
* =====================================================================
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 )
IMPLICIT NONE
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, T1, T2, T3
DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
$ SMLNUM, TST1, TST2, ULP
INTEGER I2, I4, INCOL, J, JBOT, JCOL, JLEN,
$ JROW, JTOP, K, K1, KDU, KMS, KRCOL,
$ M, M22, MBOT, MTOP, NBMPS, NDCOL,
$ NS, NU
LOGICAL ACCUM, 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 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
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 )
*
* ==== 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 = 4*NBMPS
*
* ==== Create and chase chains of NBMPS bulges ====
*
DO 180 INCOL = KTOP - 2*NBMPS + 1, KBOT - 2, 2*NBMPS
*
* JTOP = Index from which updates from the right start.
*
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
*
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 4*NBMPS column diagonal
* . chunk extends from column INCOL to column NDCOL
* . (including both column INCOL and column NDCOL). The
* . following loop chases a 2*NBMPS+1 column long chain of
* . NBMPS bulges 2*NBMPS 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 145 KRCOL = INCOL, MIN( INCOL+2*NBMPS-1, 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-KRCOL ) / 2+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 2 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+2*( M22-1 ) ).EQ.
$ ( KBOT-2 )
*
* ==== Generate reflections to chase the chain right
* . one column. (The minimum value of K is KTOP-1.) ====
*
IF ( BMP22 ) THEN
*
* ==== Special case: 2-by-2 reflection at bottom treated
* . separately ====
*
K = KRCOL + 2*( M22-1 )
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
*
* ==== Perform update from right within
* . computational window. ====
*
T1 = V( 1, M22 )
T2 = T1*DCONJG( V( 2, M22 ) )
DO 30 J = JTOP, MIN( KBOT, K+3 )
REFSUM = H( J, K+1 ) + V( 2, M22 )*H( J, K+2 )
H( J, K+1 ) = H( J, K+1 ) - REFSUM*T1
H( J, K+2 ) = H( J, K+2 ) - REFSUM*T2
30 CONTINUE
*
* ==== Perform update from left within
* . computational window. ====
*
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
T1 = DCONJG( V( 1, M22 ) )
T2 = T1*V( 2, M22 )
DO 40 J = K+1, JBOT
REFSUM = H( K+1, J ) +
$ DCONJG( V( 2, M22 ) )*H( K+2, J )
H( K+1, J ) = H( K+1, J ) - REFSUM*T1
H( K+2, J ) = H( K+2, J ) - REFSUM*T2
40 CONTINUE
*
* ==== 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( K.GE.KTOP ) THEN
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
END IF
*
* ==== Accumulate orthogonal transformations. ====
*
IF( ACCUM ) THEN
KMS = K - INCOL
DO 50 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 ) )
50 CONTINUE
ELSE IF( WANTZ ) THEN
DO 60 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 ) )
60 CONTINUE
END IF
END IF
*
* ==== Normal case: Chain of 3-by-3 reflections ====
*
DO 80 M = MBOT, MTOP, -1
K = KRCOL + 2*( 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
*
* ==== Perform delayed transformation of row below
* . Mth bulge. Exploit fact that first two elements
* . of row are actually zero. ====
*
T1 = V( 1, M )
T2 = T1*DCONJG( V( 2, M ) )
T3 = T1*DCONJG( V( 3, M ) )
REFSUM = V( 3, M )*H( K+3, K+2 )
H( K+3, K ) = -REFSUM*T1
H( K+3, K+1 ) = -REFSUM*T2
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3
*
* ==== Calculate reflection to move
* . Mth bulge one step. ====
*
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 ) )
T1 = DCONJG( VT( 1 ) )
T2 = T1*VT( 2 )
T3 = T1*VT( 3 )
REFSUM = H( K+1, K )+DCONJG( VT( 2 ) )*H( K+2, K )
*
IF( CABS1( H( K+2, K )-REFSUM*T2 )+
$ CABS1( REFSUM*T3 ).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
*
* ==== Starting 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*T1
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
*
* ==== Apply reflection from the right and
* . the first column of update from the left.
* . These updates are required for the vigilant
* . deflation check. We still delay most of the
* . updates from the left for efficiency. ====
*
T1 = V( 1, M )
T2 = T1*DCONJG( V( 2, M ) )
T3 = T1*DCONJG( V( 3, M ) )
DO 70 J = JTOP, MIN( KBOT, K+3 )
REFSUM = 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*T1
H( J, K+2 ) = H( J, K+2 ) - REFSUM*T2
H( J, K+3 ) = H( J, K+3 ) - REFSUM*T3
70 CONTINUE
*
* ==== Perform update from left for subsequent
* . column. ====
*
T1 = DCONJG( V( 1, M ) )
T2 = T1*V( 2, M )
T3 = T1*V( 3, M )
REFSUM = H( K+1, K+1 )
$ + DCONJG( V( 2, M ) )*H( K+2, K+1 )
$ + DCONJG( V( 3, M ) )*H( K+3, K+1 )
H( K+1, K+1 ) = H( K+1, K+1 ) - REFSUM*T1
H( K+2, K+1 ) = H( K+2, K+1 ) - REFSUM*T2
H( K+3, K+1 ) = H( K+3, K+1 ) - REFSUM*T3
*
* ==== 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( K.LT.KTOP)
$ CYCLE
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
80 CONTINUE
*
* ==== 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 100 M = MBOT, MTOP, -1
K = KRCOL + 2*( M-1 )
T1 = DCONJG( V( 1, M ) )
T2 = T1*V( 2, M )
T3 = T1*V( 3, M )
DO 90 J = MAX( KTOP, KRCOL + 2*M ), JBOT
REFSUM = 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*T1
H( K+2, J ) = H( K+2, J ) - REFSUM*T2
H( K+3, J ) = H( K+3, J ) - REFSUM*T3
90 CONTINUE
100 CONTINUE
*
* ==== Accumulate orthogonal transformations. ====
*
IF( ACCUM ) THEN
*
* ==== Accumulate U. (If needed, update Z later
* . with an efficient matrix-matrix
* . multiply.) ====
*
DO 120 M = MBOT, MTOP, -1
K = KRCOL + 2*( M-1 )
KMS = K - INCOL
I2 = MAX( 1, KTOP-INCOL )
I2 = MAX( I2, KMS-(KRCOL-INCOL)+1 )
I4 = MIN( KDU, KRCOL + 2*( MBOT-1 ) - INCOL + 5 )
T1 = V( 1, M )
T2 = T1*DCONJG( V( 2, M ) )
T3 = T1*DCONJG( V( 3, M ) )
DO 110 J = I2, I4
REFSUM = 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*T1
U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*T2
U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*T3
110 CONTINUE
120 CONTINUE
ELSE IF( WANTZ ) THEN
*
* ==== U is not accumulated, so update Z
* . now by multiplying by reflections
* . from the right. ====
*
DO 140 M = MBOT, MTOP, -1
K = KRCOL + 2*( M-1 )
T1 = V( 1, M )
T2 = T1*DCONJG( V( 2, M ) )
T3 = T1*DCONJG( V( 3, M ) )
DO 130 J = ILOZ, IHIZ
REFSUM = 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*T1
Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*T2
Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*T3
130 CONTINUE
140 CONTINUE
END IF
*
* ==== End of near-the-diagonal bulge chase. ====
*
145 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
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
END IF
180 CONTINUE
*
* ==== End of ZLAQR5 ====
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarcm.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarcm.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarcm.f">
*> [TXT]</a>
*> \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)
*> On entry, 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 COMPLEX*16 array, dimension (LDB, N)
*> On entry, 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[out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> On exit, 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.
*
*> \ingroup larcm
*
* =====================================================================
SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 \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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup larf
*
* =====================================================================
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZLARF1F applies an elementary reflector to a general rectangular
* matrix assuming v(1) = 1.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARF1F + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf1f.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf1f.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf1f.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARF1F( 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
*>
*> ZLARF1F applies a complex elementary reflector H to a real 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
*>
*> \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. V(1) is not referenced or modified.
*> \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
* To take advantage of the fact that v(1) = 1, we do the following
* v = [ 1 v_2 ]**T
* If SIDE='L'
* |-----|
* | C_1 |
* C =| C_2 |
* |-----|
* C_1\in\mathbb{C}^{1\times n}, C_2\in\mathbb{C}^{m-1\times n}
* So we compute:
* C = HC = (I - \tau vv**T)C
* = C - \tau vv**T C
* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T
* = C_1**T + C_2**T v ( ZGEMM then ZAXPYC-like )
* C = C - \tau vv**T C
* = C - \tau vw**T
* Giving us C_1 = C_1 - \tau w**T ( ZAXPYC-like )
* and
* C_2 = C_2 - \tau v_2w**T ( ZGERC )
* If SIDE='R'
*
* C = [ C_1 C_2 ]
* C_1\in\mathbb{C}^{m\times 1}, C_2\in\mathbb{C}^{m\times n-1}
* So we compute:
* C = CH = C(I - \tau vv**T)
* = C - \tau Cvv**T
*
* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T
* = C_1 + C_2v_2 ( ZGEMM then ZAXPYC-like )
* C = C - \tau Cvv**T
* = C - \tau wv**T
* Giving us C_1 = C_1 - \tau w ( ZAXPYC-like )
* and
* C_2 = C_2 - \tau wv_2**T ( ZGERC )
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larf
*
* =====================================================================
SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, J
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC, ZSCAL
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 1
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.
! Since we are assuming that V(1) = 1, and it is not stored, so we
! shouldn't access it.
DO WHILE( LASTV.GT.1 .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
IF( LASTC.EQ.0 ) THEN
RETURN
END IF
IF( APPLYLEFT ) THEN
*
* Form H * C
*
! Check if m = 1. This means v = 1, So we just need to compute
! C := HC = (1-\tau)C.
IF( LASTV.EQ.1 ) THEN
CALL ZSCAL(LASTC, ONE - TAU, C, LDC)
ELSE
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
*
! (I - tvv**H)C = C - tvv**H C
! First compute w**H = v**H c -> w = C**H v
! C = [ C_1 C_2 ]**T, v = [1 v_2]**T
! w = C_1**H + C_2**Hv_2
! w = C_2**Hv_2
CALL ZGEMV( 'Conjugate transpose', LASTV - 1,
$ LASTC, ONE, C( 1+1, 1 ), LDC, V( 1 + INCV ),
$ INCV, ZERO, WORK, 1 )
*
* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H
*
DO I = 1, LASTC
WORK( I ) = WORK( I ) + DCONJG( C( 1, I ) )
END DO
*
* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**H
*
! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**H
! = C(...) - tau * Conj(w(1:lastc,1))
! This is essentially a zaxpyc
DO I = 1, LASTC
C( 1, I ) = C( 1, I ) - TAU * DCONJG( WORK( I ) )
END DO
*
* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ),
$ INCV, WORK, 1, C( 1+1, 1 ), LDC )
END IF
ELSE
*
* Form C * H
*
! Check if n = 1. This means v = 1, so we just need to compute
! C := CH = C(1-\tau).
IF( LASTV.EQ.1 ) THEN
CALL ZSCAL(LASTC, ONE - TAU, C, 1)
ELSE
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
CALL ZGEMV( 'No transpose', LASTC, LASTV-1, ONE,
$ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 )
! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1)
CALL ZAXPY(LASTC, ONE, C, 1, WORK, 1)
*
* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
*
! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T
! = C(...) - tau * w(1:lastc,1)
CALL ZAXPY(LASTC, -TAU, WORK, 1, C, 1)
! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T
CALL ZGERC( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV),
$ INCV, C(1,1+1), LDC )
END IF
END IF
RETURN
*
* End of ZLARF1F
*
END
*> \brief \b ZLARF1L applies an elementary reflector to a general rectangular
* matrix assuming v(lastv) = 1, where lastv is the last non-zero
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARF1L + dependencies
*> <a
*href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarf1l.f">
*> [TGZ]</a>
*> <a
*href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarf1l.f">
*> [ZIP]</a>
*> <a
*href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarf1l.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARF1L( 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
*>
*> ZLARF1L 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 real scalar and v is a real vector assuming v(lastv) = 1,
*> where lastv is the last non-zero element.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*>
*> To apply H**H (the conjugate transpose of 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.
*
*> \ingroup larf1f
*
* =====================================================================
SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, J, LASTV, LASTC, FIRSTV
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
FIRSTV = 1
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V up to V(1).
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
I = 1
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
FIRSTV = FIRSTV + 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
IF( LASTC.EQ.0 ) THEN
RETURN
END IF
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.EQ.FIRSTV ) THEN
*
* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc)
*
CALL ZSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC )
ELSE
*
* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1)
*
CALL ZGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC,
$ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO,
$ WORK, 1 )
*
* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1)
*
DO J = 1, LASTC
WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) )
END DO
*
* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H
*
DO J = 1, LASTC
C( LASTV, J ) = C( LASTV, J )
$ - TAU * CONJG( WORK( J ) )
END DO
*
* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV,
$ WORK, 1, C( FIRSTV, 1 ), LDC)
END IF
ELSE
*
* Form C * H
*
IF( LASTV.EQ.FIRSTV ) THEN
*
* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv)
*
CALL ZSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 )
ELSE
*
* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1)
*
CALL ZGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE,
$ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO,
$ WORK, 1 )
*
* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1)
*
CALL ZAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 )
*
* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1)
*
CALL ZAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 )
*
* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H
*
CALL ZGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ),
$ INCV, C( 1, FIRSTV ), LDC )
END IF
END IF
RETURN
*
* End of ZLARF1L
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f">
*> [TXT]</a>
*> \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).
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \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.
*
*> \ingroup larfb
*
*> \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 triangular part of V (including its diagonal) is not
*> referenced.
*>
*> 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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup larfg
*
* =====================================================================
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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) .AND. (KNT .LT. 20) )
$ 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarft.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarft.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarft.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* RECURSIVE 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.
*
*> \ingroup larft
*
*> \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
*>
* =====================================================================
RECURSIVE SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV,
$ TAU, T, LDT )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments
*
CHARACTER DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
*
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* .. Parameters ..
*
COMPLEX*16 ONE, NEG_ONE, ZERO
PARAMETER(ONE=1.0D+0, ZERO = 0.0D+0, NEG_ONE=-1.0D+0)
*
* .. Local Scalars ..
*
INTEGER I,J,L
LOGICAL QR,LQ,QL,DIRF,COLV
*
* .. External Subroutines ..
*
EXTERNAL ZTRMM,ZGEMM,ZLACPY
*
* .. External Functions..
*
LOGICAL LSAME
EXTERNAL LSAME
*
* .. Intrinsic Functions..
*
INTRINSIC CONJG
*
* The general scheme used is inspired by the approach inside DGEQRT3
* which was (at the time of writing this code):
* Based on the algorithm of Elmroth and Gustavson,
* IBM J. Res. Develop. Vol 44 No. 4 July 2000.
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF(N.EQ.0.OR.K.EQ.0) THEN
RETURN
END IF
*
* Base case
*
IF(N.EQ.1.OR.K.EQ.1) THEN
T(1,1) = TAU(1)
RETURN
END IF
*
* Beginning of executable statements
*
L = K / 2
*
* Determine what kind of Q we need to compute
* We assume that if the user doesn't provide 'F' for DIRECT,
* then they meant to provide 'B' and if they don't provide
* 'C' for STOREV, then they meant to provide 'R'
*
DIRF = LSAME(DIRECT,'F')
COLV = LSAME(STOREV,'C')
*
* QR happens when we have forward direction in column storage
*
QR = DIRF.AND.COLV
*
* LQ happens when we have forward direction in row storage
*
LQ = DIRF.AND.(.NOT.COLV)
*
* QL happens when we have backward direction in column storage
*
QL = (.NOT.DIRF).AND.COLV
*
* The last case is RQ. Due to how we structured this, if the
* above 3 are false, then RQ must be true, so we never store
* this
* RQ happens when we have backward direction in row storage
* RQ = (.NOT.DIRF).AND.(.NOT.COLV)
*
IF(QR) THEN
*
* Break V apart into 6 components
*
* V = |---------------|
* |V_{1,1} 0 |
* |V_{2,1} V_{2,2}|
* |V_{3,1} V_{3,2}|
* |---------------|
*
* V_{1,1}\in\C^{l,l} unit lower triangular
* V_{2,1}\in\C^{k-l,l} rectangular
* V_{3,1}\in\C^{n-k,l} rectangular
*
* V_{2,2}\in\C^{k-l,k-l} unit lower triangular
* V_{3,2}\in\C^{n-k,k-l} rectangular
*
* We will construct the T matrix
* T = |---------------|
* |T_{1,1} T_{1,2}|
* |0 T_{2,2}|
* |---------------|
*
* T is the triangular factor obtained from block reflectors.
* To motivate the structure, assume we have already computed T_{1,1}
* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
* T_{1,1}\in\C^{l, l} upper triangular
* T_{2,2}\in\C^{k-l, k-l} upper triangular
* T_{1,2}\in\C^{l, k-l} rectangular
*
* Where l = floor(k/2)
*
* Then, consider the product:
*
* (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2')
* = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2'
*
* Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2}
*
* Then, we can define the matrix V as
* V = |-------|
* |V_1 V_2|
* |-------|
*
* So, our product is equivalent to the matrix product
* I - V*T*V'
* This means, we can compute T_{1,1} and T_{2,2}, then use this information
* to compute T_{1,2}
*
* Compute T_{1,1} recursively
*
CALL ZLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV,
$ TAU(L+1), T(L+1, L+1), LDT)
*
* Compute T_{1,2}
* T_{1,2} = V_{2,1}'
*
DO J = 1, L
DO I = 1, K-L
T(J, L+I) = CONJG(V(L+I, J))
END DO
END DO
*
* T_{1,2} = T_{1,2}*V_{2,2}
*
CALL ZTRMM('Right', 'Lower', 'No transpose', 'Unit', L,
$ K-L, ONE, V(L+1, L+1), LDV, T(1, L+1), LDT)
*
* T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2}
* Note: We assume K <= N, and GEMM will do nothing if N=K
*
CALL ZGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE,
$ V(K+1, 1), LDV, V(K+1, L+1), LDV, ONE,
$ T(1, L+1), LDT)
*
* At this point, we have that T_{1,2} = V_1'*V_2
* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2}
* respectively.
*
* T_{1,2} = -T_{1,1}*T_{1,2}
*
CALL ZTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L,
$ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT)
*
* T_{1,2} = T_{1,2}*T_{2,2}
*
CALL ZTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L,
$ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT)
ELSE IF(LQ) THEN
*
* Break V apart into 6 components
*
* V = |----------------------|
* |V_{1,1} V_{1,2} V{1,3}|
* |0 V_{2,2} V{2,3}|
* |----------------------|
*
* V_{1,1}\in\C^{l,l} unit upper triangular
* V_{1,2}\in\C^{l,k-l} rectangular
* V_{1,3}\in\C^{l,n-k} rectangular
*
* V_{2,2}\in\C^{k-l,k-l} unit upper triangular
* V_{2,3}\in\C^{k-l,n-k} rectangular
*
* Where l = floor(k/2)
*
* We will construct the T matrix
* T = |---------------|
* |T_{1,1} T_{1,2}|
* |0 T_{2,2}|
* |---------------|
*
* T is the triangular factor obtained from block reflectors.
* To motivate the structure, assume we have already computed T_{1,1}
* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
* T_{1,1}\in\C^{l, l} upper triangular
* T_{2,2}\in\C^{k-l, k-l} upper triangular
* T_{1,2}\in\C^{l, k-l} rectangular
*
* Then, consider the product:
*
* (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2)
* = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2
*
* Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2}
*
* Then, we can define the matrix V as
* V = |---|
* |V_1|
* |V_2|
* |---|
*
* So, our product is equivalent to the matrix product
* I - V'*T*V
* This means, we can compute T_{1,1} and T_{2,2}, then use this information
* to compute T_{1,2}
*
* Compute T_{1,1} recursively
*
CALL ZLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V(L+1, L+1), LDV,
$ TAU(L+1), T(L+1, L+1), LDT)
*
* Compute T_{1,2}
* T_{1,2} = V_{1,2}
*
CALL ZLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT)
*
* T_{1,2} = T_{1,2}*V_{2,2}'
*
CALL ZTRMM('Right', 'Upper', 'Conjugate', 'Unit', L, K-L,
$ ONE, V(L+1, L+1), LDV, T(1, L+1), LDT)
*
* T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2}
* Note: We assume K <= N, and GEMM will do nothing if N=K
*
CALL ZGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE,
$ V(1, K+1), LDV, V(L+1, K+1), LDV, ONE,
$ T(1, L+1), LDT)
*
* At this point, we have that T_{1,2} = V_1*V_2'
* All that is left is to pre and post multiply by -T_{1,1} and T_{2,2}
* respectively.
*
* T_{1,2} = -T_{1,1}*T_{1,2}
*
CALL ZTRMM('Left', 'Upper', 'No transpose', 'Non-unit', L,
$ K-L, NEG_ONE, T, LDT, T(1, L+1), LDT)
*
* T_{1,2} = T_{1,2}*T_{2,2}
*
CALL ZTRMM('Right', 'Upper', 'No transpose', 'Non-unit', L,
$ K-L, ONE, T(L+1, L+1), LDT, T(1, L+1), LDT)
ELSE IF(QL) THEN
*
* Break V apart into 6 components
*
* V = |---------------|
* |V_{1,1} V_{1,2}|
* |V_{2,1} V_{2,2}|
* |0 V_{3,2}|
* |---------------|
*
* V_{1,1}\in\C^{n-k,k-l} rectangular
* V_{2,1}\in\C^{k-l,k-l} unit upper triangular
*
* V_{1,2}\in\C^{n-k,l} rectangular
* V_{2,2}\in\C^{k-l,l} rectangular
* V_{3,2}\in\C^{l,l} unit upper triangular
*
* We will construct the T matrix
* T = |---------------|
* |T_{1,1} 0 |
* |T_{2,1} T_{2,2}|
* |---------------|
*
* T is the triangular factor obtained from block reflectors.
* To motivate the structure, assume we have already computed T_{1,1}
* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
* T_{1,1}\in\C^{k-l, k-l} non-unit lower triangular
* T_{2,2}\in\C^{l, l} non-unit lower triangular
* T_{2,1}\in\C^{k-l, l} rectangular
*
* Where l = floor(k/2)
*
* Then, consider the product:
*
* (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1')
* = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1'
*
* Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1}
*
* Then, we can define the matrix V as
* V = |-------|
* |V_1 V_2|
* |-------|
*
* So, our product is equivalent to the matrix product
* I - V*T*V'
* This means, we can compute T_{1,1} and T_{2,2}, then use this information
* to compute T_{2,1}
*
* Compute T_{1,1} recursively
*
CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL ZLARFT(DIRECT, STOREV, N, L, V(1, K-L+1), LDV,
$ TAU(K-L+1), T(K-L+1, K-L+1), LDT)
*
* Compute T_{2,1}
* T_{2,1} = V_{2,2}'
*
DO J = 1, K-L
DO I = 1, L
T(K-L+I, J) = CONJG(V(N-K+J, K-L+I))
END DO
END DO
*
* T_{2,1} = T_{2,1}*V_{2,1}
*
CALL ZTRMM('Right', 'Upper', 'No transpose', 'Unit', L,
$ K-L, ONE, V(N-K+1, 1), LDV, T(K-L+1, 1), LDT)
*
* T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1}
* Note: We assume K <= N, and GEMM will do nothing if N=K
*
CALL ZGEMM('Conjugate', 'No transpose', L, K-L, N-K, ONE,
$ V(1, K-L+1), LDV, V, LDV, ONE, T(K-L+1, 1),
$ LDT)
*
* At this point, we have that T_{2,1} = V_2'*V_1
* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1}
* respectively.
*
* T_{2,1} = -T_{2,2}*T_{2,1}
*
CALL ZTRMM('Left', 'Lower', 'No transpose', 'Non-unit', L,
$ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT,
$ T(K-L+1, 1), LDT)
*
* T_{2,1} = T_{2,1}*T_{1,1}
*
CALL ZTRMM('Right', 'Lower', 'No transpose', 'Non-unit', L,
$ K-L, ONE, T, LDT, T(K-L+1, 1), LDT)
ELSE
*
* Else means RQ case
*
* Break V apart into 6 components
*
* V = |-----------------------|
* |V_{1,1} V_{1,2} 0 |
* |V_{2,1} V_{2,2} V_{2,3}|
* |-----------------------|
*
* V_{1,1}\in\C^{k-l,n-k} rectangular
* V_{1,2}\in\C^{k-l,k-l} unit lower triangular
*
* V_{2,1}\in\C^{l,n-k} rectangular
* V_{2,2}\in\C^{l,k-l} rectangular
* V_{2,3}\in\C^{l,l} unit lower triangular
*
* We will construct the T matrix
* T = |---------------|
* |T_{1,1} 0 |
* |T_{2,1} T_{2,2}|
* |---------------|
*
* T is the triangular factor obtained from block reflectors.
* To motivate the structure, assume we have already computed T_{1,1}
* and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
* T_{1,1}\in\C^{k-l, k-l} non-unit lower triangular
* T_{2,2}\in\C^{l, l} non-unit lower triangular
* T_{2,1}\in\C^{k-l, l} rectangular
*
* Where l = floor(k/2)
*
* Then, consider the product:
*
* (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1)
* = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1
*
* Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1}
*
* Then, we can define the matrix V as
* V = |---|
* |V_1|
* |V_2|
* |---|
*
* So, our product is equivalent to the matrix product
* I - V'*T*V
* This means, we can compute T_{1,1} and T_{2,2}, then use this information
* to compute T_{2,1}
*
* Compute T_{1,1} recursively
*
CALL ZLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL ZLARFT(DIRECT, STOREV, N, L, V(K-L+1, 1), LDV,
$ TAU(K-L+1), T(K-L+1, K-L+1), LDT)
*
* Compute T_{2,1}
* T_{2,1} = V_{2,2}
*
CALL ZLACPY('All', L, K-L, V(K-L+1, N-K+1), LDV,
$ T(K-L+1, 1), LDT)
*
* T_{2,1} = T_{2,1}*V_{1,2}'
*
CALL ZTRMM('Right', 'Lower', 'Conjugate', 'Unit', L, K-L,
$ ONE, V(1, N-K+1), LDV, T(K-L+1, 1), LDT)
*
* T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1}
* Note: We assume K <= N, and GEMM will do nothing if N=K
*
CALL ZGEMM('No transpose', 'Conjugate', L, K-L, N-K, ONE,
$ V(K-L+1, 1), LDV, V, LDV, ONE, T(K-L+1, 1),
$ LDT)
*
* At this point, we have that T_{2,1} = V_2*V_1'
* All that is left is to pre and post multiply by -T_{2,2} and T_{1,1}
* respectively.
*
* T_{2,1} = -T_{2,2}*T_{2,1}
*
CALL ZTRMM('Left', 'Lower', 'No tranpose', 'Non-unit', L,
$ K-L, NEG_ONE, T(K-L+1, K-L+1), LDT,
$ T(K-L+1, 1), LDT)
*
* T_{2,1} = T_{2,1}*T_{1,1}
*
CALL ZTRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L,
$ K-L, ONE, T, LDT, T(K-L+1, 1), LDT)
END IF
END SUBROUTINE
*> \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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfx.f">
*> [TXT]</a>
*> \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. LDC >= 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.
*
*> \ingroup larfx
*
* =====================================================================
SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlascl.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlascl.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlascl.f">
*> [TXT]</a>
*> \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.
*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
*> TYPE = 'B', LDA >= KL+1;
*> TYPE = 'Q', LDA >= KU+1;
*> TYPE = 'Z', LDA >= 2*KL+KU+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.
*
*> \ingroup lascl
*
* =====================================================================
SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA,
$ INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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.
IF (MUL .EQ. ONE)
$ RETURN
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaset.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaset.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaset.f">
*> [TXT]</a>
*> \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[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.
*
*> \ingroup laset
*
* =====================================================================
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup lasr
*
* =====================================================================
SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaswp.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaswp.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaswp.f">
*> [TXT]</a>
*> \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
*> (K2-K1+1) is the number of elements of IPIV for which a row
*> interchange will be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
*> The vector of pivot indices. Only the elements in positions
*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
*> IPIV(K1+(K-K1)*abs(INCX)) = 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 INCX
*> 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.
*
*> \ingroup laswp
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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(K1+(I-K1)*abs(INCX)) 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 = K1 + ( K1-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 ZLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASYF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasyf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasyf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasyf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASYF computes a partial factorization of a complex symmetric matrix
*> A using the Bunch-Kaufman diagonal pivoting method. The partial
*> factorization has the form:
*>
*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
*>
*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
*> ( L21 I ) ( 0 A22 ) ( 0 I )
*>
*> where the order of D is at most NB. The actual order is returned in
*> the argument KB, and is either NB or NB-1, or N if N <= NB.
*> Note that U**T denotes the transpose of U.
*>
*> ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code
*> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
*> A22 (if UPLO = 'L').
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric 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] NB
*> \verbatim
*> NB is INTEGER
*> The maximum number of columns of the matrix A that should be
*> factored. NB should be at least 2 to allow for 2-by-2 pivot
*> blocks.
*> \endverbatim
*>
*> \param[out] KB
*> \verbatim
*> KB is INTEGER
*> The number of columns of A that were actually factored.
*> KB is either NB-1 or NB, or N if N <= NB.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the symmetric 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, A contains details of the partial factorization.
*> \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)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> Only the last KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> Only the first KB elements of IPIV are set.
*>
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (LDW,NB)
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D is
*> exactly singular.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lahef
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> November 2013, Igor Kozachenko,
*> Computer Science Division,
*> University of California, Berkeley
*> \endverbatim
*
* =====================================================================
SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KB, LDA, LDW, N, NB
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP,
$ KSTEP, KW
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX
COMPLEX*16 D11, D21, D22, R1, T, Z
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
EXTERNAL LSAME, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Factorize the trailing columns of A using the upper triangle
* of A and working backwards, and compute the matrix W = U12*D
* for use in updating A11
*
* K is the main loop index, decreasing from N in steps of 1 or 2
*
* KW is the column of W which corresponds to column K of A
*
K = N
10 CONTINUE
KW = NB + K - N
*
* Exit from loop
*
IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
$ GO TO 30
*
* Copy column K of A to column KW of W and update it
*
CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
IF( K.LT.N )
$ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
$ LDA,
$ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( W( K, KW ) )
*
* IMAX is the row-index of the largest off-diagonal element in
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
COLMAX = CABS1( W( IMAX, KW ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column KW-1 of W and update it
*
CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
$ W( IMAX+1, KW-1 ), 1 )
IF( K.LT.N )
$ CALL ZGEMV( 'No transpose', K, N-K, -CONE,
$ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
$ CONE, W( 1, KW-1 ), 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
ROWMAX = CABS1( W( JMAX, KW-1 ) )
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column KW-1 of W to column KW of W
*
CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K - KSTEP + 1
*
* KKW is the column of W which corresponds to column KK of A
*
KKW = NB + KK - N
*
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KKW of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K-1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = A( KK, KK )
CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
IF( KP.GT.1 )
$ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
*
* Interchange rows KK and KP in last K+1 to N columns of A
* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in last KKW to NB columns of W.
*
IF( K.LT.N )
$ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
$ LDA )
CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
$ LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column kw of W now holds
*
* W(kw) = U(k)*D(k),
*
* where U(k) is the k-th column of U
*
* Store subdiag. elements of column U(k)
* and 1-by-1 block D(k) in column k of A.
* NOTE: Diagonal element U(k,k) is a UNIT element
* and not stored.
* A(k,k) := D(k,k) = W(k,kw)
* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
*
CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
R1 = CONE / A( K, K )
CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
*
ELSE
*
* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
*
* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
* block D(k-1:k,k-1:k) in columns k-1 and k of A.
* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
* block and not stored.
* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
*
IF( K.GT.2 ) THEN
*
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K-1, KW )
D11 = W( K, KW ) / D21
D22 = W( K-1, KW-1 ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
*
* Update elements in columns A(k-1) and A(k) as
* dot products of rows of ( W(kw-1) W(kw) ) and columns
* of D**(-1)
*
DO 20 J = 1, K - 2
A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
20 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K-1, K-1 ) = W( K-1, KW-1 )
A( K-1, K ) = W( K-1, KW )
A( K, K ) = W( K, KW )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
30 CONTINUE
*
* Update the upper triangle of A11 (= A(1:k,1:k)) as
*
* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
*
CALL ZGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K,
$ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW,
$ CONE, A( 1, 1 ), LDA )
*
* Put U12 in standard form by partially undoing the interchanges
* in columns k+1:n looping backwards from k+1 to n
*
J = K + 1
60 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J + 1
END IF
* (NOTE: Here, J is used to determine row length. Length N-J+1
* of the rows to swap back doesn't include diagonal element)
J = J + 1
IF( JP.NE.JJ .AND. J.LE.N )
$ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
IF( J.LT.N )
$ GO TO 60
*
* Set KB to the number of columns factorized
*
KB = N - K
*
ELSE
*
* Factorize the leading columns of A using the lower triangle
* of A and working forwards, and compute the matrix W = L21*D
* for use in updating A22
*
* K is the main loop index, increasing from 1 in steps of 1 or 2
*
K = 1
70 CONTINUE
*
* Exit from loop
*
IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
$ GO TO 90
*
* Copy column K of A to column K of W and update it
*
CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
$ LDA,
$ W( K, 1 ), LDW, CONE, W( K, K ), 1 )
*
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( W( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
COLMAX = CABS1( W( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero or underflow: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* Copy column IMAX to column K+1 of W and update it
*
CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ),
$ 1 )
CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX,
$ K+1 ),
$ 1 )
CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K,
$ 1 ),
$ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
$ 1 )
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
ROWMAX = CABS1( W( JMAX, K+1 ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
*
* copy column K+1 of W to column K of W
*
CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
* ============================================================
*
* KK is the column of A where pivoting step stopped
*
KK = K + KSTEP - 1
*
* Interchange rows and columns KP and KK.
* Updated column KP is already stored in column KK of W.
*
IF( KP.NE.KK ) THEN
*
* Copy non-updated column KK to column KP of submatrix A
* at step K. No need to copy element into column K
* (or K and K+1 for 2-by-2 pivot) of A, since these columns
* will be later overwritten.
*
A( KP, KP ) = A( KK, KK )
CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
IF( KP.LT.N )
$ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ),
$ 1 )
*
* Interchange rows KK and KP in first K-1 columns of A
* (columns K (or K and K+1 for 2-by-2 pivot) of A will be
* later overwritten). Interchange rows KK and KP
* in first KK columns of W.
*
IF( K.GT.1 )
$ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
END IF
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k of W now holds
*
* W(k) = L(k)*D(k),
*
* where L(k) is the k-th column of L
*
* Store subdiag. elements of column L(k)
* and 1-by-1 block D(k) in column k of A.
* (NOTE: Diagonal element L(k,k) is a UNIT element
* and not stored)
* A(k,k) := D(k,k) = W(k,k)
* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
*
CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
IF( K.LT.N ) THEN
R1 = CONE / A( K, K )
CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
*
ELSE
*
* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
* block D(k:k+1,k:k+1) in columns k and k+1 of A.
* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
* block and not stored)
* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
*
IF( K.LT.N-1 ) THEN
*
* Compose the columns of the inverse of 2-by-2 pivot
* block D in the following way to reduce the number
* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by
* this inverse
*
* D**(-1) = ( d11 d21 )**(-1) =
* ( d21 d22 )
*
* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
* ( (-d21 ) ( d11 ) )
*
* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
*
* * ( ( d22/d21 ) ( -1 ) ) =
* ( ( -1 ) ( d11/d21 ) )
*
* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) =
* ( ( -1 ) ( D22 ) )
*
* = 1/d21 * T * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
* = D21 * ( ( D11 ) ( -1 ) )
* ( ( -1 ) ( D22 ) )
*
D21 = W( K+1, K )
D11 = W( K+1, K+1 ) / D21
D22 = W( K, K ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
*
* Update elements in columns A(k) and A(k+1) as
* dot products of rows of ( W(k) W(k+1) ) and columns
* of D**(-1)
*
DO 80 J = K + 2, N
A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
80 CONTINUE
END IF
*
* Copy D(k) to A
*
A( K, K ) = W( K, K )
A( K+1, K ) = W( K+1, K )
A( K+1, K+1 ) = W( K+1, K+1 )
*
END IF
*
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 70
*
90 CONTINUE
*
* Update the lower triangle of A22 (= A(k:n,k:n)) as
*
* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
*
CALL ZGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1,
$ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW,
$ CONE, A( K, K ), LDA )
*
* Put L21 in standard form by partially undoing the interchanges
* of rows in columns 1:k-1 looping backwards from k-1 to 1
*
J = K - 1
120 CONTINUE
*
* Undo the interchanges (if any) of rows JJ and JP at each
* step J
*
* (Here, J is a diagonal index)
JJ = J
JP = IPIV( J )
IF( JP.LT.0 ) THEN
JP = -JP
* (Here, J is a diagonal index)
J = J - 1
END IF
* (NOTE: Here, J is used to determine row length. Length J
* of the rows to swap back doesn't include diagonal element)
J = J - 1
IF( JP.NE.JJ .AND. J.GE.1 )
$ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
IF( J.GT.1 )
$ GO TO 120
*
* Set KB to the number of columns factorized
*
KB = K - 1
*
END IF
RETURN
*
* End of ZLASYF
*
END
*> \brief \b ZLATBS solves a triangular banded system of equations.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATBS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatbs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatbs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatbs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
* SCALE, CNORM, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORMIN, TRANS, UPLO
* INTEGER INFO, KD, LDAB, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* DOUBLE PRECISION CNORM( * )
* COMPLEX*16 AB( LDAB, * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATBS 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, where A is an upper or lower
*> triangular band matrix. Here A**T denotes the 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 ZTBSV 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] KD
*> \verbatim
*> KD is INTEGER
*> The number of subdiagonals or superdiagonals in the
*> triangular matrix A. KD >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> The upper or lower triangular band matrix A, stored in the
*> first KD+1 rows of the array. The j-th column of A is stored
*> in the j-th column of the array AB as follows:
*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KD+1.
*> \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.
*
*> \ingroup latbs
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A rough bound on x is computed; if that is less than overflow, ZTBSV
*> 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 ZTBSV 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 ZTBSV if 1/M(n) and 1/G(n) are both greater
*> than max(underflow, 1/overflow).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB,
$ X,
$ SCALE, CNORM, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, KD, LDAB, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION CNORM( * )
COMPLEX*16 AB( LDAB, * ), 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, JLEN, MAIND
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, ZTBSV
* ..
* .. 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( KD.LT.0 ) THEN
INFO = -6
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLATBS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
SCALE = ONE
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
*
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
JLEN = MIN( KD, J-1 )
CNORM( J ) = DZASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 ) THEN
CNORM( J ) = DZASUM( JLEN, AB( 2, J ), 1 )
ELSE
CNORM( J ) = ZERO
END IF
20 CONTINUE
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 ZTBSV 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
MAIND = KD + 1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
MAIND = 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 = AB( MAIND, 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
MAIND = KD + 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
MAIND = 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 = AB( MAIND, 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 ZTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, 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 = AB( MAIND, 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(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
* x(j)* A(max(1,j-kd):j-1,j)
*
JLEN = MIN( KD, J-1 )
CALL ZAXPY( JLEN, -X( J )*TSCAL,
$ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 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:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
* x(j) * A(j+1:min(j+kd,n),j)
*
JLEN = MIN( KD, N-J )
IF( JLEN.GT.0 )
$ CALL ZAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
$ X( J+1 ), 1 )
I = J + IZAMAX( N-J, X( J+1 ), 1 )
XMAX = CABS1( X( I ) )
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 = AB( MAIND, 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
JLEN = MIN( KD, J-1 )
CSUMJ = ZDOTU( JLEN, AB( KD+1-JLEN, J ), 1,
$ X( J-JLEN ), 1 )
ELSE
JLEN = MIN( KD, N-J )
IF( JLEN.GT.1 )
$ CSUMJ = ZDOTU( JLEN, AB( 2, J ), 1, X( J+1 ),
$ 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
DO 130 I = 1, JLEN
CSUMJ = CSUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
$ X( J-JLEN-1+I )
130 CONTINUE
ELSE
JLEN = MIN( KD, N-J )
DO 140 I = 1, JLEN
CSUMJ = CSUMJ + ( AB( I+1, J )*USCAL )*X( J+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
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AB( MAIND, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 160
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/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( AB( MAIND, 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
JLEN = MIN( KD, J-1 )
CSUMJ = ZDOTC( JLEN, AB( KD+1-JLEN, J ), 1,
$ X( J-JLEN ), 1 )
ELSE
JLEN = MIN( KD, N-J )
IF( JLEN.GT.1 )
$ CSUMJ = ZDOTC( JLEN, AB( 2, J ), 1, X( J+1 ),
$ 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
JLEN = MIN( KD, J-1 )
DO 180 I = 1, JLEN
CSUMJ = CSUMJ + ( DCONJG( AB( KD+I-JLEN, J ) )*
$ USCAL )*X( J-JLEN-1+I )
180 CONTINUE
ELSE
JLEN = MIN( KD, N-J )
DO 190 I = 1, JLEN
CSUMJ = CSUMJ + ( DCONJG( AB( I+1, J ) )*USCAL )
$ *X( J+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
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = DCONJG( AB( MAIND, J ) )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 210
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/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 ZLATBS
*
END
*> \brief \b ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATDF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatdf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatdf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatdf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
* JPIV )
*
* .. Scalar Arguments ..
* INTEGER IJOB, LDZ, N
* DOUBLE PRECISION RDSCAL, RDSUM
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* COMPLEX*16 RHS( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATDF computes the contribution to the reciprocal Dif-estimate
*> by solving for x in Z * x = b, where b is chosen such that the norm
*> of x is as large as possible. It is assumed that LU decomposition
*> of Z has been computed by ZGETC2. On entry RHS = f holds the
*> contribution from earlier solved sub-systems, and on return RHS = x.
*>
*> The factorization of Z returned by ZGETC2 has the form
*> Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
*> triangular with unit diagonal elements and U is upper triangular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> IJOB = 2: First compute an approximative null-vector e
*> of Z using ZGECON, e is normalized and solve for
*> Zx = +-e - f with the sign giving the greater value of
*> 2-norm(x). About 5 times as expensive as Default.
*> IJOB .ne. 2: Local look ahead strategy where
*> all entries of the r.h.s. b is chosen as either +1 or
*> -1. Default.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Z.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> On entry, the LU part of the factorization of the n-by-n
*> matrix Z computed by ZGETC2: Z = P * L * U * Q
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDA >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] RHS
*> \verbatim
*> RHS is COMPLEX*16 array, dimension (N).
*> On entry, RHS contains contributions from other subsystems.
*> On exit, RHS contains the solution of the subsystem with
*> entries according to the value of IJOB (see above).
*> \endverbatim
*>
*> \param[in,out] RDSUM
*> \verbatim
*> RDSUM is DOUBLE PRECISION
*> On entry, the sum of squares of computed contributions to
*> the Dif-estimate under computation by ZTGSYL, where the
*> scaling factor RDSCAL (see below) has been factored out.
*> On exit, the corresponding sum of squares updated with the
*> contributions from the current sub-system.
*> If TRANS = 'T' RDSUM is not touched.
*> NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.
*> \endverbatim
*>
*> \param[in,out] RDSCAL
*> \verbatim
*> RDSCAL is DOUBLE PRECISION
*> On entry, scaling factor used to prevent overflow in RDSUM.
*> On exit, RDSCAL is updated w.r.t. the current contributions
*> in RDSUM.
*> If TRANS = 'T', RDSCAL is not touched.
*> NOTE: RDSCAL only makes sense when ZTGSY2 is called by
*> ZTGSYL.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup latdf
*
*> \par Further Details:
* =====================
*>
*> This routine is a further developed implementation of algorithm
*> BSOLVE in [1] using complete pivoting in the LU factorization.
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> [1] Bo Kagstrom and Lars Westin,
*> Generalized Schur Methods with Condition Estimators for
*> Solving the Generalized Sylvester Equation, IEEE Transactions
*> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
*>\n
*> [2] Peter Poromaa,
*> On Efficient and Robust Estimators for the Separation
*> between two Regular Matrix Pairs with Applications in
*> Condition Estimation. Report UMINF-95.05, Department of
*> Computing Science, Umea University, S-901 87 Umea, Sweden,
*> 1995.
*
* =====================================================================
SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
$ JPIV )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER IJOB, LDZ, N
DOUBLE PRECISION RDSCAL, RDSUM
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
COMPLEX*16 RHS( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXDIM
PARAMETER ( MAXDIM = 2 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K
DOUBLE PRECISION RTEMP, SCALE, SMINU, SPLUS
COMPLEX*16 BM, BP, PMONE, TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( MAXDIM )
COMPLEX*16 WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZCOPY, ZGECON, ZGESC2, ZLASSQ,
$ ZLASWP,
$ ZSCAL
* ..
* .. External Functions ..
DOUBLE PRECISION DZASUM
COMPLEX*16 ZDOTC
EXTERNAL DZASUM, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( IJOB.NE.2 ) THEN
*
* Apply permutations IPIV to RHS
*
CALL ZLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
*
* Solve for L-part choosing RHS either to +1 or -1.
*
PMONE = -CONE
DO 10 J = 1, N - 1
BP = RHS( J ) + CONE
BM = RHS( J ) - CONE
SPLUS = ONE
*
* Look-ahead for L- part RHS(1:N-1) = +-1
* SPLUS and SMIN computed more efficiently than in BSOLVE[1].
*
SPLUS = SPLUS + DBLE( ZDOTC( N-J, Z( J+1, J ), 1, Z( J+1,
$ J ), 1 ) )
SMINU = DBLE( ZDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ),
$ 1 ) )
SPLUS = SPLUS*DBLE( RHS( J ) )
IF( SPLUS.GT.SMINU ) THEN
RHS( J ) = BP
ELSE IF( SMINU.GT.SPLUS ) THEN
RHS( J ) = BM
ELSE
*
* In this case the updating sums are equal and we can
* choose RHS(J) +1 or -1. The first time this happens we
* choose -1, thereafter +1. This is a simple way to get
* good estimates of matrices like Byers well-known example
* (see [1]). (Not done in BSOLVE.)
*
RHS( J ) = RHS( J ) + PMONE
PMONE = CONE
END IF
*
* Compute the remaining r.h.s.
*
TEMP = -RHS( J )
CALL ZAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
10 CONTINUE
*
* Solve for U- part, lockahead for RHS(N) = +-1. This is not done
* In BSOLVE and will hopefully give us a better estimate because
* any ill-conditioning of the original matrix is transferred to U
* and not to L. U(N, N) is an approximation to sigma_min(LU).
*
CALL ZCOPY( N-1, RHS, 1, WORK, 1 )
WORK( N ) = RHS( N ) + CONE
RHS( N ) = RHS( N ) - CONE
SPLUS = ZERO
SMINU = ZERO
DO 30 I = N, 1, -1
TEMP = CONE / Z( I, I )
WORK( I ) = WORK( I )*TEMP
RHS( I ) = RHS( I )*TEMP
DO 20 K = I + 1, N
WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP )
RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
20 CONTINUE
SPLUS = SPLUS + ABS( WORK( I ) )
SMINU = SMINU + ABS( RHS( I ) )
30 CONTINUE
IF( SPLUS.GT.SMINU )
$ CALL ZCOPY( N, WORK, 1, RHS, 1 )
*
* Apply the permutations JPIV to the computed solution (RHS)
*
CALL ZLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
*
* Compute the sum of squares
*
CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
RETURN
END IF
*
* ENTRY IJOB = 2
*
* Compute approximate nullvector XM of Z
*
CALL ZGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO )
CALL ZCOPY( N, WORK( N+1 ), 1, XM, 1 )
*
* Compute RHS
*
CALL ZLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
TEMP = CONE / SQRT( ZDOTC( N, XM, 1, XM, 1 ) )
CALL ZSCAL( N, TEMP, XM, 1 )
CALL ZCOPY( N, XM, 1, XP, 1 )
CALL ZAXPY( N, CONE, RHS, 1, XP, 1 )
CALL ZAXPY( N, -CONE, XM, 1, RHS, 1 )
CALL ZGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE )
CALL ZGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE )
IF( DZASUM( N, XP, 1 ).GT.DZASUM( N, RHS, 1 ) )
$ CALL ZCOPY( N, XP, 1, RHS, 1 )
*
* Compute the sum of squares
*
CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
RETURN
*
* End of ZLATDF
*
END
*> \brief \b ZLATPS solves a triangular system of equations with the matrix held in packed storage.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATPS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatps.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatps.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatps.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
* CNORM, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORMIN, TRANS, UPLO
* INTEGER INFO, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* DOUBLE PRECISION CNORM( * )
* COMPLEX*16 AP( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATPS 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, where A is an upper or lower
*> triangular matrix stored in packed form. Here 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 ZTPSV 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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangular matrix A, packed columnwise in
*> a linear array. The j-th column of A is stored in the array
*> AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=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.
*
*> \ingroup latps
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A rough bound on x is computed; if that is less than overflow, ZTPSV
*> 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 ZTPSV 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 ZTPSV if 1/M(n) and 1/G(n) are both greater
*> than max(underflow, 1/overflow).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION CNORM( * )
COMPLEX*16 AP( * ), 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, IP, J, JFIRST, JINC, JLAST, JLEN
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, ZTPSV
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLATPS', -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
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.
*
IP = 1
DO 10 J = 1, N
CNORM( J ) = DZASUM( J-1, AP( IP ), 1 )
IP = IP + J
10 CONTINUE
ELSE
*
* A is lower triangular.
*
IP = 1
DO 20 J = 1, N - 1
CNORM( J ) = DZASUM( N-J, AP( IP+1 ), 1 )
IP = IP + N - 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 ZTPSV 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
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = N
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 60
*
TJJS = AP( IP )
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
IP = IP + JINC*JLEN
JLEN = JLEN - 1
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
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
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 = AP( IP )
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
JLEN = JLEN + 1
IP = IP + JINC*JLEN
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 ZTPSV( UPLO, TRANS, DIAG, N, AP, 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
*
IP = JFIRST*( JFIRST+1 ) / 2
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 = AP( IP )*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, AP( IP-J+1 ), 1,
$ X,
$ 1 )
I = IZAMAX( J-1, X, 1 )
XMAX = CABS1( X( I ) )
END IF
IP = IP - J
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, AP( IP+1 ), 1,
$ X( J+1 ), 1 )
I = J + IZAMAX( N-J, X( J+1 ), 1 )
XMAX = CABS1( X( I ) )
END IF
IP = IP + N - J + 1
END IF
120 CONTINUE
*
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Solve A**T * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
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 = AP( IP )*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, AP( IP-J+1 ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTU( N-J, AP( IP+1 ), 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 + ( AP( IP-J+I )*USCAL )*X( I )
130 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 140 I = 1, N - J
CSUMJ = CSUMJ + ( AP( IP+I )*USCAL )*X( J+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
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = AP( IP )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 160
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/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 ) ) )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
170 CONTINUE
*
ELSE
*
* Solve A**H * x = b
*
IP = JFIRST*( JFIRST+1 ) / 2
JLEN = 1
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( AP( IP ) )*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, AP( IP-J+1 ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTC( N-J, AP( IP+1 ), 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( AP( IP-J+I ) )*USCAL )
$ *X( I )
180 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 190 I = 1, N - J
CSUMJ = CSUMJ + ( DCONJG( AP( IP+I ) )*USCAL )*
$ X( J+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
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJS = DCONJG( AP( IP ) )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 210
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/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 ) ) )
JLEN = JLEN + 1
IP = IP + JINC*JLEN
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 ZLATPS
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrd.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrd.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrd.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup latrd
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 ) = DBLE( 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 ) = DBLE( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrs.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup latrs
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*
SCALE = ONE
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
*
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
*
* Avoid NaN generation if entries in CNORM exceed the
* overflow threshold
*
IF ( TMAX.LE.DLAMCH('Overflow') ) THEN
* Case 1: All entries in CNORM are valid floating-point numbers
TSCAL = HALF / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
ELSE
* Case 2: At least one column norm of A cannot be
* represented as a floating-point number. Find the
* maximum offdiagonal absolute value
* max( |Re(A(I,J))|, |Im(A(I,J)| ). If this entry is
* not +/- Infinity, use this value as TSCAL.
TMAX = ZERO
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO J = 2, N
DO I = 1, J - 1
TMAX = MAX( TMAX, ABS( DBLE( A( I, J ) ) ),
$ ABS( DIMAG(A ( I, J ) ) ) )
END DO
END DO
ELSE
*
* A is lower triangular.
*
DO J = 1, N - 1
DO I = J + 1, N
TMAX = MAX( TMAX, ABS( DBLE( A( I, J ) ) ),
$ ABS( DIMAG(A ( I, J ) ) ) )
END DO
END DO
END IF
*
IF( TMAX.LE.DLAMCH('Overflow') ) THEN
TSCAL = ONE / ( SMLNUM*TMAX )
DO J = 1, N
IF( CNORM( J ).LE.DLAMCH('Overflow') ) THEN
CNORM( J ) = CNORM( J )*TSCAL
ELSE
* Recompute the 1-norm of each column without
* introducing Infinity in the summation.
TSCAL = TWO * TSCAL
CNORM( J ) = ZERO
IF( UPPER ) THEN
DO I = 1, J - 1
CNORM( J ) = CNORM( J ) +
$ TSCAL * CABS2( A( I, J ) )
END DO
ELSE
DO I = J + 1, N
CNORM( J ) = CNORM( J ) +
$ TSCAL * CABS2( A( I, J ) )
END DO
END IF
TSCAL = TSCAL * HALF
END IF
END DO
ELSE
* At least one entry of A is not a valid floating-point
* entry. Rely on TRSV to propagate Inf and NaN.
CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
RETURN
END IF
END IF
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 ZLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAUU2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlauu2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlauu2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlauu2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAUU2 computes the product U * U**H or L**H * L, where the triangular
*> factor U or L is stored in the upper or lower triangular part of
*> the array A.
*>
*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
*> overwriting the factor U in A.
*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
*> overwriting the factor L in A.
*>
*> This is the unblocked form of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the triangular factor stored in the array A
*> is upper or lower triangular:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the triangular factor U or L. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the triangular factor U or L.
*> On exit, if UPLO = 'U', the upper triangle of A is
*> overwritten with the upper triangle of the product U * U**H;
*> if UPLO = 'L', the lower triangle of A is overwritten with
*> the lower triangle of the product L**H * L.
*> \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
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lauu2
*
* =====================================================================
SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, MAX
* ..
* .. 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( 'ZLAUU2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the product U * U**H.
*
DO 10 I = 1, N
AII = DBLE( A( I, I ) )
IF( I.LT.N ) THEN
A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ),
$ LDA,
$ A( I, I+1 ), LDA ) )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1,
$ I+1 ),
$ LDA, A( I, I+1 ), LDA, DCMPLX( AII ),
$ A( 1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
ELSE
CALL ZDSCAL( I, AII, A( 1, I ), 1 )
END IF
10 CONTINUE
*
ELSE
*
* Compute the product L**H * L.
*
DO 20 I = 1, N
AII = DBLE( A( I, I ) )
IF( I.LT.N ) THEN
A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ),
$ 1,
$ A( I+1, I ), 1 ) )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1,
$ DCMPLX( AII ), A( I, 1 ), LDA )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
ELSE
CALL ZDSCAL( I, AII, A( I, 1 ), LDA )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of ZLAUU2
*
END
*> \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAUUM + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlauum.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlauum.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlauum.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAUUM computes the product U * U**H or L**H * L, where the triangular
*> factor U or L is stored in the upper or lower triangular part of
*> the array A.
*>
*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
*> overwriting the factor U in A.
*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
*> overwriting the factor L in A.
*>
*> This is the blocked form of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the triangular factor stored in the array A
*> is upper or lower triangular:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the triangular factor U or L. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the triangular factor U or L.
*> On exit, if UPLO = 'U', the upper triangle of A is
*> overwritten with the upper triangle of the product U * U**H;
*> if UPLO = 'L', the lower triangle of A is overwritten with
*> the lower triangle of the product L**H * L.
*> \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
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lauum
*
* =====================================================================
SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM
* ..
* .. 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( 'ZLAUUM', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZLAUUM', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL ZLAUU2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute the product U * U**H.
*
DO 10 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
$ A( 1, I ), LDA )
CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
$ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
$ LDA )
CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
$ ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute the product L**H * L.
*
DO 20 I = 1, N, NB
IB = MIN( NB, N-I+1 )
CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose',
$ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
$ A( I, 1 ), LDA )
CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
IF( I+IB.LE.N ) THEN
CALL ZGEMM( 'Conjugate transpose', 'No transpose',
$ IB,
$ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
$ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
CALL ZHERK( 'Lower', 'Conjugate transpose', IB,
$ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
$ A( I, I ), LDA )
END IF
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZLAUUM
*
END
*> \brief \b ZPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPBTF2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpbtf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpbtf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpbtf2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPBTF2 computes the Cholesky factorization of a complex Hermitian
*> positive definite band 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, U**H is the conjugate transpose
*> of U, 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] KD
*> \verbatim
*> KD is INTEGER
*> The number of super-diagonals of the matrix A if UPLO = 'U',
*> or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the upper or lower triangle of the Hermitian band
*> matrix A, stored in the first KD+1 rows of the array. The
*> j-th column of A is stored in the j-th column of the array AB
*> as follows:
*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*>
*> On exit, if INFO = 0, the triangular factor U or L from the
*> Cholesky factorization A = U**H *U or A = L*L**H of the band
*> matrix A, in the same storage format as A.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KD+1.
*> \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 principal minor of order k
*> is not positive, 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.
*
*> \ingroup pbtf2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> N = 6, KD = 2, and UPLO = 'U':
*>
*> On entry: On exit:
*>
*> * * a13 a24 a35 a46 * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*>
*> Similarly, if UPLO = 'L' the format of A is as follows:
*>
*> On entry: On exit:
*>
*> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
*> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
*> a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*>
*> Array elements marked * are not used by the routine.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, KLD, KN
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHER, ZLACGV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, 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( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPBTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
KLD = MAX( 1, LDAB-1 )
*
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( AB( KD+1, J ) )
IF( AJJ.LE.ZERO ) THEN
AB( KD+1, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AB( KD+1, J ) = AJJ
*
* Compute elements J+1:J+KN of row J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL ZDSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
CALL ZLACGV( KN, AB( KD, J+1 ), KLD )
CALL ZHER( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
$ AB( KD+1, J+1 ), KLD )
CALL ZLACGV( KN, AB( KD, J+1 ), KLD )
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( AB( 1, J ) )
IF( AJJ.LE.ZERO ) THEN
AB( 1, J ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AB( 1, J ) = AJJ
*
* Compute elements J+1:J+KN of column J and update the
* trailing submatrix within the band.
*
KN = MIN( KD, N-J )
IF( KN.GT.0 ) THEN
CALL ZDSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
CALL ZHER( 'Lower', KN, -ONE, AB( 2, J ), 1,
$ AB( 1, J+1 ), KLD )
END IF
20 CONTINUE
END IF
RETURN
*
30 CONTINUE
INFO = J
RETURN
*
* End of ZPBTF2
*
END
*> \brief \b ZPBTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPBTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpbtrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpbtrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpbtrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AB( LDAB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPBTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite band 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.
*> \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] KD
*> \verbatim
*> KD is INTEGER
*> The number of superdiagonals of the matrix A if UPLO = 'U',
*> or the number of subdiagonals if UPLO = 'L'. KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is COMPLEX*16 array, dimension (LDAB,N)
*> On entry, the upper or lower triangle of the Hermitian band
*> matrix A, stored in the first KD+1 rows of the array. The
*> j-th column of A is stored in the j-th column of the array AB
*> as follows:
*> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
*>
*> On exit, if INFO = 0, the triangular factor U or L from the
*> Cholesky factorization A = U**H*U or A = L*L**H of the band
*> matrix A, in the same storage format as A.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> The leading dimension of the array AB. LDAB >= KD+1.
*> \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 principal minor of order i
*> is not positive, 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.
*
*> \ingroup pbtrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The band storage scheme is illustrated by the following example, when
*> N = 6, KD = 2, and UPLO = 'U':
*>
*> On entry: On exit:
*>
*> * * a13 a24 a35 a46 * * u13 u24 u35 u46
*> * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
*> a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
*>
*> Similarly, if UPLO = 'L' the format of A is as follows:
*>
*> On entry: On exit:
*>
*> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
*> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
*> a31 a42 a53 a64 * * l31 l42 l53 l64 * *
*>
*> Array elements marked * are not used by the routine.
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
*
* =====================================================================
SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, KD, LDAB, N
* ..
* .. Array Arguments ..
COMPLEX*16 AB( LDAB, * )
* ..
*
* =====================================================================
*
* .. 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 ) )
INTEGER NBMAX, LDWORK
PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 )
* ..
* .. Local Scalars ..
INTEGER I, I2, I3, IB, II, J, JJ, NB
* ..
* .. Local Arrays ..
COMPLEX*16 WORK( LDWORK, NBMAX )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZHERK, ZPBTF2, ZPOTF2,
$ ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
$ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( KD.LT.0 ) THEN
INFO = -3
ELSE IF( LDAB.LT.KD+1 ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPBTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment
*
NB = ILAENV( 1, 'ZPBTRF', UPLO, N, KD, -1, -1 )
*
* The block size must not exceed the semi-bandwidth KD, and must not
* exceed the limit set by the size of the local array WORK.
*
NB = MIN( NB, NBMAX )
*
IF( NB.LE.1 .OR. NB.GT.KD ) THEN
*
* Use unblocked code
*
CALL ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
ELSE
*
* Use blocked code
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Compute the Cholesky factorization of a Hermitian band
* matrix, given the upper triangle of the matrix in band
* storage.
*
* Zero the upper triangle of the work array.
*
DO 20 J = 1, NB
DO 10 I = 1, J - 1
WORK( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 70 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL ZPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11 A12 A13
* A22 A23
* A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A12, A22 and
* A23 are empty if IB = KD. The upper triangle of A13
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A12
*
CALL ZTRSM( 'Left', 'Upper',
$ 'Conjugate transpose',
$ 'Non-unit', IB, I2, CONE,
$ AB( KD+1, I ), LDAB-1,
$ AB( KD+1-IB, I+IB ), LDAB-1 )
*
* Update A22
*
CALL ZHERK( 'Upper', 'Conjugate transpose', I2,
$ IB,
$ -ONE, AB( KD+1-IB, I+IB ), LDAB-1, ONE,
$ AB( KD+1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the lower triangle of A13 into the work array.
*
DO 40 JJ = 1, I3
DO 30 II = JJ, IB
WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
30 CONTINUE
40 CONTINUE
*
* Update A13 (in the work array).
*
CALL ZTRSM( 'Left', 'Upper',
$ 'Conjugate transpose',
$ 'Non-unit', IB, I3, CONE,
$ AB( KD+1, I ), LDAB-1, WORK, LDWORK )
*
* Update A23
*
IF( I2.GT.0 )
$ CALL ZGEMM( 'Conjugate transpose',
$ 'No transpose', I2, I3, IB, -CONE,
$ AB( KD+1-IB, I+IB ), LDAB-1, WORK,
$ LDWORK, CONE, AB( 1+IB, I+KD ),
$ LDAB-1 )
*
* Update A33
*
CALL ZHERK( 'Upper', 'Conjugate transpose', I3,
$ IB,
$ -ONE, WORK, LDWORK, ONE,
$ AB( KD+1, I+KD ), LDAB-1 )
*
* Copy the lower triangle of A13 back into place.
*
DO 60 JJ = 1, I3
DO 50 II = JJ, IB
AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
50 CONTINUE
60 CONTINUE
END IF
END IF
70 CONTINUE
ELSE
*
* Compute the Cholesky factorization of a Hermitian band
* matrix, given the lower triangle of the matrix in band
* storage.
*
* Zero the lower triangle of the work array.
*
DO 90 J = 1, NB
DO 80 I = J + 1, NB
WORK( I, J ) = ZERO
80 CONTINUE
90 CONTINUE
*
* Process the band matrix one diagonal block at a time.
*
DO 140 I = 1, N, NB
IB = MIN( NB, N-I+1 )
*
* Factorize the diagonal block
*
CALL ZPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
IF( II.NE.0 ) THEN
INFO = I + II - 1
GO TO 150
END IF
IF( I+IB.LE.N ) THEN
*
* Update the relevant part of the trailing submatrix.
* If A11 denotes the diagonal block which has just been
* factorized, then we need to update the remaining
* blocks in the diagram:
*
* A11
* A21 A22
* A31 A32 A33
*
* The numbers of rows and columns in the partitioning
* are IB, I2, I3 respectively. The blocks A21, A22 and
* A32 are empty if IB = KD. The lower triangle of A31
* lies outside the band.
*
I2 = MIN( KD-IB, N-I-IB+1 )
I3 = MIN( IB, N-I-KD+1 )
*
IF( I2.GT.0 ) THEN
*
* Update A21
*
CALL ZTRSM( 'Right', 'Lower',
$ 'Conjugate transpose', 'Non-unit', I2,
$ IB, CONE, AB( 1, I ), LDAB-1,
$ AB( 1+IB, I ), LDAB-1 )
*
* Update A22
*
CALL ZHERK( 'Lower', 'No transpose', I2, IB,
$ -ONE,
$ AB( 1+IB, I ), LDAB-1, ONE,
$ AB( 1, I+IB ), LDAB-1 )
END IF
*
IF( I3.GT.0 ) THEN
*
* Copy the upper triangle of A31 into the work array.
*
DO 110 JJ = 1, IB
DO 100 II = 1, MIN( JJ, I3 )
WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
100 CONTINUE
110 CONTINUE
*
* Update A31 (in the work array).
*
CALL ZTRSM( 'Right', 'Lower',
$ 'Conjugate transpose', 'Non-unit', I3,
$ IB, CONE, AB( 1, I ), LDAB-1, WORK,
$ LDWORK )
*
* Update A32
*
IF( I2.GT.0 )
$ CALL ZGEMM( 'No transpose',
$ 'Conjugate transpose', I3, I2, IB,
$ -CONE, WORK, LDWORK, AB( 1+IB, I ),
$ LDAB-1, CONE, AB( 1+KD-IB, I+IB ),
$ LDAB-1 )
*
* Update A33
*
CALL ZHERK( 'Lower', 'No transpose', I3, IB,
$ -ONE,
$ WORK, LDWORK, ONE, AB( 1, I+KD ),
$ LDAB-1 )
*
* Copy the upper triangle of A31 back into place.
*
DO 130 JJ = 1, IB
DO 120 II = 1, MIN( JJ, I3 )
AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
120 CONTINUE
130 CONTINUE
END IF
END IF
140 CONTINUE
END IF
END IF
RETURN
*
150 CONTINUE
RETURN
*
* End of ZPBTRF
*
END
*> \brief \b ZPOCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpocon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpocon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpocon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOCON estimates the reciprocal of the condition number (in the
*> 1-norm) of a complex Hermitian positive definite matrix using the
*> Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \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] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The triangular factor U or L from the Cholesky factorization
*> A = U**H*U or A = L*L**H, as computed by ZPOTRF.
*> \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
*> The 1-norm (or infinity-norm) of the Hermitian 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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \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.
*
*> \ingroup pocon
*
* =====================================================================
SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
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 UPPER
CHARACTER NORMIN
INTEGER IX, KASE
DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
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
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( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOCON', -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 1-norm of inv(A).
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U**H).
*
CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, A, LDA, WORK, SCALEL, RWORK, INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ A, LDA, WORK, SCALEU, RWORK, INFO )
ELSE
*
* Multiply by inv(L).
*
CALL ZLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ A, LDA, WORK, SCALEL, RWORK, INFO )
NORMIN = 'Y'
*
* Multiply by inv(L**H).
*
CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, A, LDA, WORK, SCALEU, RWORK, INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
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 ZPOCON
*
END
*> \brief \b ZPOEQU
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOEQU + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpoequ.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpoequ.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpoequ.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, N
* DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION S( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOEQU computes row and column scalings intended to equilibrate a
*> Hermitian positive definite matrix A and reduce its condition number
*> (with respect to the two-norm). S contains the scale factors,
*> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
*> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
*> choice of S puts the condition number of B within a factor N of the
*> smallest possible condition number over all possible diagonal
*> scalings.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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 N-by-N Hermitian positive definite matrix whose scaling
*> factors are to be computed. Only the diagonal elements of A
*> are referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, S contains the scale factors for A.
*> \endverbatim
*>
*> \param[out] SCOND
*> \verbatim
*> SCOND is DOUBLE PRECISION
*> If INFO = 0, S contains the ratio of the smallest S(i) to
*> the largest S(i). If SCOND >= 0.1 and AMAX is neither too
*> large nor too small, it is not worth scaling by S.
*> \endverbatim
*>
*> \param[out] AMAX
*> \verbatim
*> AMAX is DOUBLE PRECISION
*> Absolute value of largest matrix element. If AMAX is very
*> close to overflow or very close to underflow, the matrix
*> should be scaled.
*> \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 is nonpositive.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup poequ
*
* =====================================================================
SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
DOUBLE PRECISION AMAX, SCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION SMIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOEQU', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
SCOND = ONE
AMAX = ZERO
RETURN
END IF
*
* Find the minimum and maximum diagonal elements.
*
S( 1 ) = DBLE( A( 1, 1 ) )
SMIN = S( 1 )
AMAX = S( 1 )
DO 10 I = 2, N
S( I ) = DBLE( A( I, I ) )
SMIN = MIN( SMIN, S( I ) )
AMAX = MAX( AMAX, S( I ) )
10 CONTINUE
*
IF( SMIN.LE.ZERO ) THEN
*
* Find the first non-positive diagonal element and return.
*
DO 20 I = 1, N
IF( S( I ).LE.ZERO ) THEN
INFO = I
RETURN
END IF
20 CONTINUE
ELSE
*
* Set the scale factors to the reciprocals
* of the diagonal elements.
*
DO 30 I = 1, N
S( I ) = ONE / SQRT( S( I ) )
30 CONTINUE
*
* Compute SCOND = min(S(I)) / max(S(I))
*
SCOND = SQRT( SMIN ) / SQRT( AMAX )
END IF
RETURN
*
* End of ZPOEQU
*
END
*> \brief \b ZPORFS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPORFS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zporfs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zporfs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zporfs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
* LDX, FERR, BERR, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPORFS improves the computed solution to a system of linear
*> equations when the coefficient matrix is Hermitian positive definite,
*> and provides error bounds and backward error estimates for the
*> solution.
*> \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] 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)
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] AF
*> \verbatim
*> AF is COMPLEX*16 array, dimension (LDAF,N)
*> The triangular factor U or L from the Cholesky factorization
*> A = U**H*U or A = L*L**H, as computed by ZPOTRF.
*> \endverbatim
*>
*> \param[in] LDAF
*> \verbatim
*> LDAF is INTEGER
*> The leading dimension of the array AF. LDAF >= max(1,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> On entry, the solution matrix X, as computed by ZPOTRS.
*> On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup porfs
*
* =====================================================================
SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
$ LDX, FERR, BERR, WORK, RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* ..
* .. Array Arguments ..
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* ====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D+0 )
DOUBLE PRECISION THREE
PARAMETER ( THREE = 3.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER COUNT, I, J, K, KASE, NZ
DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
COMPLEX*16 ZDUM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZCOPY, ZHEMV, ZLACN2,
$ ZPOTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. 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' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPORFS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
DO 10 J = 1, NRHS
FERR( J ) = ZERO
BERR( J ) = ZERO
10 CONTINUE
RETURN
END IF
*
* NZ = maximum number of nonzero elements in each row of A, plus 1
*
NZ = N + 1
EPS = DLAMCH( 'Epsilon' )
SAFMIN = DLAMCH( 'Safe minimum' )
SAFE1 = NZ*SAFMIN
SAFE2 = SAFE1 / EPS
*
* Do for each right hand side
*
DO 140 J = 1, NRHS
*
COUNT = 1
LSTRES = THREE
20 CONTINUE
*
* Loop until stopping criterion is satisfied.
*
* Compute residual R = B - A * X
*
CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
CALL ZHEMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK,
$ 1 )
*
* Compute componentwise relative backward error from formula
*
* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
*
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z. If the i-th component of the denominator is less
* than SAFE2, then SAFE1 is added to the i-th components of the
* numerator and denominator before dividing.
*
DO 30 I = 1, N
RWORK( I ) = CABS1( B( I, J ) )
30 CONTINUE
*
* Compute abs(A)*abs(X) + abs(B).
*
IF( UPPER ) THEN
DO 50 K = 1, N
S = ZERO
XK = CABS1( X( K, J ) )
DO 40 I = 1, K - 1
RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
40 CONTINUE
RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK + S
50 CONTINUE
ELSE
DO 70 K = 1, N
S = ZERO
XK = CABS1( X( K, J ) )
RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK
DO 60 I = K + 1, N
RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
60 CONTINUE
RWORK( K ) = RWORK( K ) + S
70 CONTINUE
END IF
S = ZERO
DO 80 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
ELSE
S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
$ ( RWORK( I )+SAFE1 ) )
END IF
80 CONTINUE
BERR( J ) = S
*
* Test stopping criterion. Continue iterating if
* 1) The residual BERR(J) is larger than machine epsilon, and
* 2) BERR(J) decreased by at least a factor of 2 during the
* last iteration, and
* 3) At most ITMAX iterations tried.
*
IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
$ COUNT.LE.ITMAX ) THEN
*
* Update solution and try again.
*
CALL ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
LSTRES = BERR( J )
COUNT = COUNT + 1
GO TO 20
END IF
*
* Bound error from formula
*
* norm(X - XTRUE) / norm(X) .le. FERR =
* norm( abs(inv(A))*
* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
*
* where
* norm(Z) is the magnitude of the largest component of Z
* inv(A) is the inverse of A
* abs(Z) is the componentwise absolute value of the matrix or
* vector Z
* NZ is the maximum number of nonzeros in any row of A, plus 1
* EPS is machine epsilon
*
* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
* is incremented by SAFE1 if the i-th component of
* abs(A)*abs(X) + abs(B) is less than SAFE2.
*
* Use ZLACN2 to estimate the infinity-norm of the matrix
* inv(A) * diag(W),
* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
*
DO 90 I = 1, N
IF( RWORK( I ).GT.SAFE2 ) THEN
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
ELSE
RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
$ SAFE1
END IF
90 CONTINUE
*
KASE = 0
100 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Multiply by diag(W)*inv(A**H).
*
CALL ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
DO 110 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
110 CONTINUE
ELSE IF( KASE.EQ.2 ) THEN
*
* Multiply by inv(A)*diag(W).
*
DO 120 I = 1, N
WORK( I ) = RWORK( I )*WORK( I )
120 CONTINUE
CALL ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
END IF
GO TO 100
END IF
*
* Normalize error.
*
LSTRES = ZERO
DO 130 I = 1, N
LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
130 CONTINUE
IF( LSTRES.NE.ZERO )
$ FERR( J ) = FERR( J ) / LSTRES
*
140 CONTINUE
*
RETURN
*
* End of ZPORFS
*
END
*> \brief <b> ZPOSV computes the solution to system of linear equations A * X = B for PO matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOSV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zposv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zposv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zposv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOSV computes the solution to a complex system of linear equations
*> A * X = B,
*> where A is an N-by-N Hermitian positive definite matrix and X and B
*> are N-by-NRHS matrices.
*>
*> The Cholesky decomposition is used to factor A as
*> 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 a lower triangular
*> matrix. The factored form of A is then used to solve the system of
*> equations A * X = B.
*> \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 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 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[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS 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, the leading principal minor of order i
*> of A is not positive, so the factorization could not
*> be completed, and the solution has not been computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup posv
*
* =====================================================================
SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZPOTRF, ZPOTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND.
$ .NOT.LSAME( UPLO, 'L' ) ) 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOSV ', -INFO )
RETURN
END IF
*
* Compute the Cholesky factorization A = U**H *U or A = L*L**H.
*
CALL ZPOTRF( UPLO, N, A, LDA, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
END IF
RETURN
*
* End of ZPOSV
*
END
*> \brief <b> ZPOSVX computes the solution to system of linear equations A * X = B for PO matrices</b>
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOSVX + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zposvx.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zposvx.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zposvx.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
* S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
* RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER EQUED, FACT, UPLO
* INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ), S( * )
* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
* $ WORK( * ), X( LDX, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
*> compute the solution to a complex system of linear equations
*> A * X = B,
*> where A is an N-by-N Hermitian positive definite matrix and X and B
*> are N-by-NRHS matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
* =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'E', real scaling factors are computed to equilibrate
*> the system:
*> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
*> Whether or not the system will be equilibrated depends on the
*> scaling of the matrix A, but if equilibration is used, A is
*> overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
*>
*> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
*> factor the matrix A (after equilibration if FACT = 'E') as
*> 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 a lower triangular
*> matrix.
*>
*> 3. If the leading principal minor of order i is not positive,
*> then the routine returns with INFO = i. Otherwise, the factored
*> form of A is used to estimate the condition number of the matrix
*> A. If the reciprocal of the condition number is less than machine
*> precision, INFO = N+1 is returned as a warning, but the routine
*> still goes on to solve for X and compute error bounds as
*> described below.
*>
*> 4. The system of equations is solved for X using the factored form
*> of A.
*>
*> 5. Iterative refinement is applied to improve the computed solution
*> matrix and calculate error bounds and backward error estimates
*> for it.
*>
*> 6. If equilibration was used, the matrix X is premultiplied by
*> diag(S) so that it solves the original system before
*> equilibration.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] FACT
*> \verbatim
*> FACT is CHARACTER*1
*> Specifies whether or not the factored form of the matrix A is
*> supplied on entry, and if not, whether the matrix A should be
*> equilibrated before it is factored.
*> = 'F': On entry, AF contains the factored form of A.
*> If EQUED = 'Y', the matrix A has been equilibrated
*> with scaling factors given by S. A and AF will not
*> be modified.
*> = 'N': The matrix A will be copied to AF and factored.
*> = 'E': The matrix A will be equilibrated if necessary, then
*> copied to AF and factored.
*> \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 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 matrices B and X. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A, except if FACT = 'F' and
*> EQUED = 'Y', then A must contain the equilibrated matrix
*> diag(S)*A*diag(S). 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. A is not modified if
*> FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
*>
*> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
*> diag(S)*A*diag(S).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] AF
*> \verbatim
*> AF is COMPLEX*16 array, dimension (LDAF,N)
*> If FACT = 'F', then AF is an input argument and on entry
*> contains the triangular factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H, in the same storage
*> format as A. If EQUED .ne. 'N', then AF is the factored form
*> of the equilibrated matrix diag(S)*A*diag(S).
*>
*> If FACT = 'N', then AF is an output argument and on exit
*> returns the triangular factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H of the original
*> matrix A.
*>
*> If FACT = 'E', then AF is an output argument and on exit
*> returns the triangular factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H of the equilibrated
*> matrix A (see the description of A for the form of the
*> equilibrated matrix).
*> \endverbatim
*>
*> \param[in] LDAF
*> \verbatim
*> LDAF is INTEGER
*> The leading dimension of the array AF. LDAF >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] EQUED
*> \verbatim
*> EQUED is CHARACTER*1
*> Specifies the form of equilibration that was done.
*> = 'N': No equilibration (always true if FACT = 'N').
*> = 'Y': Equilibration was done, i.e., A has been replaced by
*> diag(S) * A * diag(S).
*> EQUED is an input argument if FACT = 'F'; otherwise, it is an
*> output argument.
*> \endverbatim
*>
*> \param[in,out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (N)
*> The scale factors for A; not accessed if EQUED = 'N'. S is
*> an input argument if FACT = 'F'; otherwise, S is an output
*> argument. If FACT = 'F' and EQUED = 'Y', each element of S
*> must be positive.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS righthand side matrix B.
*> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
*> B is overwritten by diag(S) * B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NRHS)
*> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
*> the original system of equations. Note that if EQUED = 'Y',
*> A and B are modified on exit, and the solution to the
*> equilibrated system is inv(diag(S))*X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The estimate of the reciprocal condition number of the matrix
*> A after equilibration (if done). If RCOND is less than the
*> machine precision (in particular, if RCOND = 0), the matrix
*> is singular to working precision. This condition is
*> indicated by a return code of INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*> FERR is DOUBLE PRECISION array, dimension (NRHS)
*> The estimated forward error bound for each solution vector
*> X(j) (the j-th column of the solution matrix X).
*> If XTRUE is the true solution corresponding to X(j), FERR(j)
*> is an estimated upper bound for the magnitude of the largest
*> element in (X(j) - XTRUE) divided by the magnitude of the
*> largest element in X(j). The estimate is as reliable as
*> the estimate for RCOND, and is almost always a slight
*> overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*> BERR is DOUBLE PRECISION array, dimension (NRHS)
*> The componentwise relative backward error of each solution
*> vector X(j) (i.e., the smallest relative change in
*> any element of A or B that makes X(j) an exact solution).
*> \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
*> > 0: if INFO = i, and i is
*> <= N: the leading principal minor of order i of A
*> is not positive, so the factorization could not
*> be completed, and the solution has not been
*> computed. RCOND = 0 is returned.
*> = N+1: U is nonsingular, but RCOND is less than machine
*> precision, meaning that the matrix is singular
*> to working precision. Nevertheless, the
*> solution and error bounds are computed because
*> there are a number of situations where the
*> computed solution can be more accurate than the
*> value of RCOND would suggest.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup posvx
*
* =====================================================================
SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF,
$ EQUED,
$ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
$ RWORK, INFO )
*
* -- LAPACK driver routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER EQUED, FACT, UPLO
INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ), S( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
$ WORK( * ), X( LDX, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL EQUIL, NOFACT, RCEQU
INTEGER I, INFEQU, J
DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACPY, ZLAQHE, ZPOCON, ZPOEQU,
$ ZPORFS,
$ ZPOTRF, ZPOTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
NOFACT = LSAME( FACT, 'N' )
EQUIL = LSAME( FACT, 'E' )
IF( NOFACT .OR. EQUIL ) THEN
EQUED = 'N'
RCEQU = .FALSE.
ELSE
RCEQU = LSAME( EQUED, 'Y' )
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
END IF
*
* Test the input parameters.
*
IF( .NOT.NOFACT .AND.
$ .NOT.EQUIL .AND.
$ .NOT.LSAME( FACT, 'F' ) )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND.
$ .NOT.LSAME( UPLO, 'L' ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( NRHS.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
$ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
INFO = -9
ELSE
IF( RCEQU ) THEN
SMIN = BIGNUM
SMAX = ZERO
DO 10 J = 1, N
SMIN = MIN( SMIN, S( J ) )
SMAX = MAX( SMAX, S( J ) )
10 CONTINUE
IF( SMIN.LE.ZERO ) THEN
INFO = -10
ELSE IF( N.GT.0 ) THEN
SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
ELSE
SCOND = ONE
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOSVX', -INFO )
RETURN
END IF
*
IF( EQUIL ) THEN
*
* Compute row and column scalings to equilibrate the matrix A.
*
CALL ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
IF( INFEQU.EQ.0 ) THEN
*
* Equilibrate the matrix.
*
CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
RCEQU = LSAME( EQUED, 'Y' )
END IF
END IF
*
* Scale the right hand side.
*
IF( RCEQU ) THEN
DO 30 J = 1, NRHS
DO 20 I = 1, N
B( I, J ) = S( I )*B( I, J )
20 CONTINUE
30 CONTINUE
END IF
*
IF( NOFACT .OR. EQUIL ) THEN
*
* Compute the Cholesky factorization A = U**H *U or A = L*L**H.
*
CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF )
CALL ZPOTRF( UPLO, N, AF, LDAF, INFO )
*
* Return if INFO is non-zero.
*
IF( INFO.GT.0 )THEN
RCOND = ZERO
RETURN
END IF
END IF
*
* Compute the norm of the matrix A.
*
ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
*
* Compute the reciprocal of the condition number of A.
*
CALL ZPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* Compute the solution matrix X.
*
CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
CALL ZPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
*
* Use iterative refinement to improve the computed solution and
* compute error bounds and backward error estimates for it.
*
CALL ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
$ FERR, BERR, WORK, RWORK, INFO )
*
* Transform the solution matrix X to a solution of the original
* system.
*
IF( RCEQU ) THEN
DO 50 J = 1, NRHS
DO 40 I = 1, N
X( I, J ) = S( I )*X( I, J )
40 CONTINUE
50 CONTINUE
DO 60 J = 1, NRHS
FERR( J ) = FERR( J ) / SCOND
60 CONTINUE
END IF
*
* Set INFO = N+1 if the matrix is singular to working precision.
*
IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
$ INFO = N + 1
*
RETURN
*
* End of ZPOSVX
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotf2.f">
*> [TXT]</a>
*> \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 principal minor of order k
*> is not positive, 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.
*
*> \ingroup potf2
*
* =====================================================================
SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ) ) - DBLE( 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 ) ) - DBLE( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotrf.f">
*> [TXT]</a>
*> \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 principal minor of order i
*> is not positive, 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.
*
*> \ingroup potrf
*
* =====================================================================
SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, ZPOTRF2,
$ 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 ZPOTRF2( 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 ZPOTRF2( '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 ZPOTRF2( '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 ZPOTRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRF2 computes the Cholesky factorization of a Hermitian
*> positive definite matrix A using the recursive algorithm.
*>
*> 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 recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = n/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> The subroutine calls itself to factor A11. Update and scale A21
*> or A12, update A22 then call itself to factor A22.
*>
*> \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 principal minor of order i
*> is not positive, 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.
*
*> \ingroup potrf2
*
* =====================================================================
RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 N1, N2, IINFO
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZHERK, ZTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, DBLE, 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( 'ZPOTRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* N=1 case
*
IF( N.EQ.1 ) THEN
*
* Test for non-positive-definiteness
*
AJJ = DBLE( A( 1, 1 ) )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
INFO = 1
RETURN
END IF
*
* Factor
*
A( 1, 1 ) = SQRT( AJJ )
*
* Use recursive code
*
ELSE
N1 = N/2
N2 = N-N1
*
* Factor A11
*
CALL ZPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Compute the Cholesky factorization A = U**H*U
*
IF( UPPER ) THEN
*
* Update and scale A12
*
CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE,
$ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA )
*
* Update and factor A22
*
CALL ZHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
*
* Compute the Cholesky factorization A = L*L**H
*
ELSE
*
* Update and scale A21
*
CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE,
$ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA )
*
* Update and factor A22
*
CALL ZHERK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
END IF
END IF
RETURN
*
* End of ZPOTRF2
*
END
*> \brief \b ZPOTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRI computes the inverse of a complex Hermitian positive definite
*> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
*> computed by ZPOTRF.
*> \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 triangular factor U or L from the Cholesky
*> factorization A = U**H*U or A = L*L**H, as computed by
*> ZPOTRF.
*> On exit, the upper or lower triangle of the (Hermitian)
*> inverse of A, overwriting the input factor U or L.
*> \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 (i,i) element of the factor U or L is
*> zero, and the inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup potri
*
* =====================================================================
SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLAUUM, ZTRTRI
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .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( 'ZPOTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL ZTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
* Form inv(U) * inv(U)**H or inv(L)**H * inv(L).
*
CALL ZLAUUM( UPLO, N, A, LDA, INFO )
*
RETURN
*
* End of ZPOTRI
*
END
*> \brief \b ZPOTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpotrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpotrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpotrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRS solves a system of linear equations A*X = B with a Hermitian
*> positive definite matrix A using the Cholesky factorization
*> A = U**H * U or A = L * L**H computed by ZPOTRF.
*> \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] 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 factor U or L from the Cholesky factorization
*> A = U**H * U or A = L * L**H, as computed by ZPOTRF.
*> \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, 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.
*
*> \ingroup potrs
*
* =====================================================================
SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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( 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 = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U**H *U.
*
* Solve U**H *X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
$ 'Non-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*X = B where A = L*L**H.
*
* Solve L*X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
*
* Solve L**H *X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', 'Conjugate transpose',
$ 'Non-unit',
$ N, NRHS, ONE, A, LDA, B, LDB )
END IF
*
RETURN
*
* End of ZPOTRS
*
END
*> \brief \b ZPPCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPPCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zppcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zppcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zppcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPPCON estimates the reciprocal of the condition number (in the
*> 1-norm) of a complex Hermitian positive definite packed matrix using
*> the Cholesky factorization A = U**H*U or A = L*L**H computed by
*> ZPPTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The triangular factor U or L from the Cholesky factorization
*> A = U**H*U or A = L*L**H, packed columnwise in a linear
*> array. The j-th column of U or L is stored in the array AP
*> as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-norm (or infinity-norm) of the Hermitian 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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \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.
*
*> \ingroup ppcon
*
* =====================================================================
SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
CHARACTER NORMIN
INTEGER IX, KASE
DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
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, ZLATPS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. 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' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPPCON', -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 1-norm of the inverse.
*
KASE = 0
NORMIN = 'N'
10 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( UPPER ) THEN
*
* Multiply by inv(U**H).
*
CALL ZLATPS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, AP, WORK, SCALEL, RWORK, INFO )
NORMIN = 'Y'
*
* Multiply by inv(U).
*
CALL ZLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ AP, WORK, SCALEU, RWORK, INFO )
ELSE
*
* Multiply by inv(L).
*
CALL ZLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ AP, WORK, SCALEL, RWORK, INFO )
NORMIN = 'Y'
*
* Multiply by inv(L**H).
*
CALL ZLATPS( 'Lower', 'Conjugate transpose', 'Non-unit',
$ NORMIN, N, AP, WORK, SCALEU, RWORK, INFO )
END IF
*
* Multiply by 1/SCALE if doing so will not cause overflow.
*
SCALE = SCALEL*SCALEU
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 ZPPCON
*
END
*> \brief \b ZPPTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPPTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpptrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpptrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpptrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPPTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A stored in packed format.
*>
*> 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.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> See below for further details.
*>
*> On exit, if INFO = 0, the triangular factor U or L from the
*> Cholesky factorization A = U**H*U or A = L*L**H, in the same
*> storage format as A.
*> \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 principal minor of order i
*> is not positive, 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.
*
*> \ingroup pptrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The packed storage scheme is illustrated by the following example
*> when N = 4, UPLO = 'U':
*>
*> Two-dimensional storage of the Hermitian matrix A:
*>
*> a11 a12 a13 a14
*> a22 a23 a24
*> a33 a34 (aij = conjg(aji))
*> a44
*>
*> Packed storage of the upper triangle of A:
*>
*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPPTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**H * U.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
*
* Compute elements 1:J-1 of column J.
*
IF( J.GT.1 )
$ CALL ZTPSV( 'Upper', 'Conjugate transpose',
$ 'Non-unit',
$ J-1, AP, AP( JC ), 1 )
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( AP( JJ ) ) - DBLE( ZDOTC( J-1,
$ AP( JC ), 1, AP( JC ), 1 ) )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AP( JJ ) = SQRT( AJJ )
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L * L**H.
*
JJ = 1
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( AP( JJ ) )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AP( JJ ) = AJJ
*
* Compute elements J+1:N of column J and update the trailing
* submatrix.
*
IF( J.LT.N ) THEN
CALL ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
CALL ZHPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
$ AP( JJ+N-J+1 ) )
JJ = JJ + N - J + 1
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of ZPPTRF
*
END
*> \brief \b ZPPTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPPTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpptri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpptri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpptri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPPTRI computes the inverse of a complex Hermitian positive definite
*> matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
*> computed by ZPPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangular factor is stored in AP;
*> = 'L': Lower triangular factor is stored in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the triangular factor U or L from the Cholesky
*> factorization A = U**H*U or A = L*L**H, packed columnwise as
*> a linear array. The j-th column of U or L is stored in the
*> array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
*>
*> On exit, the upper or lower triangle of the (Hermitian)
*> inverse of A, overwriting the input factor U or L.
*> \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,i) element of the factor U or L is
*> zero, and the inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup pptri
*
* =====================================================================
SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ, JJN
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPMV, ZTPTRI
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Invert the triangular Cholesky factor U or L.
*
CALL ZTPTRI( UPLO, 'Non-unit', N, AP, INFO )
IF( INFO.GT.0 )
$ RETURN
IF( UPPER ) THEN
*
* Compute the product inv(U) * inv(U)**H.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
IF( J.GT.1 )
$ CALL ZHPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
AJJ = DBLE( AP( JJ ) )
CALL ZDSCAL( J, AJJ, AP( JC ), 1 )
10 CONTINUE
*
ELSE
*
* Compute the product inv(L)**H * inv(L).
*
JJ = 1
DO 20 J = 1, N
JJN = JJ + N - J + 1
AP( JJ ) = DBLE( ZDOTC( N-J+1, AP( JJ ), 1, AP( JJ ),
$ 1 ) )
IF( J.LT.N )
$ CALL ZTPMV( 'Lower', 'Conjugate transpose',
$ 'Non-unit',
$ N-J, AP( JJN ), AP( JJ+1 ), 1 )
JJ = JJN
20 CONTINUE
END IF
*
RETURN
*
* End of ZPPTRI
*
END
*> \brief \b ZPPTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPPTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpptrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpptrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpptrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPPTRS solves a system of linear equations A*X = B with a Hermitian
*> positive definite matrix A in packed storage using the Cholesky
*> factorization A = U**H * U or A = L * L**H computed by ZPPTRF.
*> \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] 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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The triangular factor U or L from the Cholesky factorization
*> A = U**H * U or A = L * L**H, packed columnwise in a linear
*> array. The j-th column of U or L is stored in the array AP
*> as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=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, 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.
*
*> \ingroup pptrs
*
* =====================================================================
SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B where A = U**H * U.
*
DO 10 I = 1, NRHS
*
* Solve U**H *X = B, overwriting B with X.
*
CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit',
$ N,
$ AP, B( 1, I ), 1 )
*
* Solve U*X = B, overwriting B with X.
*
CALL ZTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
10 CONTINUE
ELSE
*
* Solve A*X = B where A = L * L**H.
*
DO 20 I = 1, NRHS
*
* Solve L*Y = B, overwriting B with X.
*
CALL ZTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
$ B( 1, I ), 1 )
*
* Solve L**H *X = Y, overwriting B with X.
*
CALL ZTPSV( 'Lower', 'Conjugate transpose', 'Non-unit',
$ N,
$ AP, B( 1, I ), 1 )
20 CONTINUE
END IF
*
RETURN
*
* End of ZPPTRS
*
END
*> \brief \b ZPSTF2 computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPSTF2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpstf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpstf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpstf2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION TOL
* INTEGER INFO, LDA, N, RANK
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* DOUBLE PRECISION WORK( 2*N )
* INTEGER PIV( N )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPSTF2 computes the Cholesky factorization with complete
*> pivoting of a complex Hermitian positive semidefinite matrix A.
*>
*> The factorization has the form
*> P**T * A * P = U**H * U , if UPLO = 'U',
*> P**T * A * P = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular, and
*> P is stored as vector PIV.
*>
*> This algorithm does not attempt to check that A is positive
*> semidefinite. This version of the algorithm calls level 2 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric 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 symmetric 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 as above.
*> \endverbatim
*>
*> \param[out] PIV
*> \verbatim
*> PIV is INTEGER array, dimension (N)
*> PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
*> \endverbatim
*>
*> \param[out] RANK
*> \verbatim
*> RANK is INTEGER
*> The rank of A given by the number of steps the algorithm
*> completed.
*> \endverbatim
*>
*> \param[in] TOL
*> \verbatim
*> TOL is DOUBLE PRECISION
*> User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )
*> will be used. The algorithm terminates at the (K-1)st step
*> if the pivot <= TOL.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (2*N)
*> Work space.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> < 0: If INFO = -K, the K-th argument had an illegal value,
*> = 0: algorithm completed successfully, and
*> > 0: the matrix A is either rank deficient with computed rank
*> as returned in RANK, or is not positive semidefinite. See
*> Section 7 of LAPACK Working Note #161 for further
*> information.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup pstf2
*
* =====================================================================
SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION TOL
INTEGER INFO, LDA, N, RANK
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
DOUBLE PRECISION WORK( 2*N )
INTEGER PIV( N )
* ..
*
* =====================================================================
*
* .. 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 ..
COMPLEX*16 ZTEMP
DOUBLE PRECISION AJJ, DSTOP, DTEMP
INTEGER I, ITEMP, J, PVT
LOGICAL UPPER
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
LOGICAL LSAME, DISNAN
EXTERNAL DLAMCH, LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZGEMV, ZLACGV, ZSWAP,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCONJG, 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( 'ZPSTF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Initialize PIV
*
DO 100 I = 1, N
PIV( I ) = I
100 CONTINUE
*
* Compute stopping value
*
DO 110 I = 1, N
WORK( I ) = DBLE( A( I, I ) )
110 CONTINUE
PVT = MAXLOC( WORK( 1:N ), 1 )
AJJ = DBLE( A( PVT, PVT ) )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
RANK = 0
INFO = 1
GO TO 200
END IF
*
* Compute stopping value if not supplied
*
IF( TOL.LT.ZERO ) THEN
DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ
ELSE
DSTOP = TOL
END IF
*
* Set first half of WORK to zero, holds dot products
*
DO 120 I = 1, N
WORK( I ) = 0
120 CONTINUE
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization P**T * A * P = U**H* U
*
DO 150 J = 1, N
*
* Find pivot, test for exit, else swap rows and columns
* Update dot products, compute possible pivots which are
* stored in the second half of WORK
*
DO 130 I = J, N
*
IF( J.GT.1 ) THEN
WORK( I ) = WORK( I ) +
$ DBLE( DCONJG( A( J-1, I ) )*
$ A( J-1, I ) )
END IF
WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I )
*
130 CONTINUE
*
IF( J.GT.1 ) THEN
ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
PVT = ITEMP + J - 1
AJJ = WORK( N+PVT )
IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 190
END IF
END IF
*
IF( J.NE.PVT ) THEN
*
* Pivot OK, so can now swap pivot rows and columns
*
A( PVT, PVT ) = A( J, J )
CALL ZSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 )
IF( PVT.LT.N )
$ CALL ZSWAP( N-PVT, A( J, PVT+1 ), LDA,
$ A( PVT, PVT+1 ), LDA )
DO 140 I = J + 1, PVT - 1
ZTEMP = DCONJG( A( J, I ) )
A( J, I ) = DCONJG( A( I, PVT ) )
A( I, PVT ) = ZTEMP
140 CONTINUE
A( J, PVT ) = DCONJG( A( J, PVT ) )
*
* Swap dot products and PIV
*
DTEMP = WORK( J )
WORK( J ) = WORK( PVT )
WORK( PVT ) = DTEMP
ITEMP = PIV( PVT )
PIV( PVT ) = PIV( J )
PIV( J ) = ITEMP
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( 'Trans', 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
*
150 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization P**T * A * P = L * L**H
*
DO 180 J = 1, N
*
* Find pivot, test for exit, else swap rows and columns
* Update dot products, compute possible pivots which are
* stored in the second half of WORK
*
DO 160 I = J, N
*
IF( J.GT.1 ) THEN
WORK( I ) = WORK( I ) +
$ DBLE( DCONJG( A( I, J-1 ) )*
$ A( I, J-1 ) )
END IF
WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I )
*
160 CONTINUE
*
IF( J.GT.1 ) THEN
ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
PVT = ITEMP + J - 1
AJJ = WORK( N+PVT )
IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 190
END IF
END IF
*
IF( J.NE.PVT ) THEN
*
* Pivot OK, so can now swap pivot rows and columns
*
A( PVT, PVT ) = A( J, J )
CALL ZSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA )
IF( PVT.LT.N )
$ CALL ZSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1,
$ PVT ),
$ 1 )
DO 170 I = J + 1, PVT - 1
ZTEMP = DCONJG( A( I, J ) )
A( I, J ) = DCONJG( A( PVT, I ) )
A( PVT, I ) = ZTEMP
170 CONTINUE
A( PVT, J ) = DCONJG( A( PVT, J ) )
*
* Swap dot products and PIV
*
DTEMP = WORK( J )
WORK( J ) = WORK( PVT )
WORK( PVT ) = DTEMP
ITEMP = PIV( PVT )
PIV( PVT ) = PIV( J )
PIV( J ) = ITEMP
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 Trans', 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
*
180 CONTINUE
*
END IF
*
* Ran to completion, A has full rank
*
RANK = N
*
GO TO 200
190 CONTINUE
*
* Rank is number of steps completed. Set INFO = 1 to signal
* that the factorization cannot be used to solve a system.
*
RANK = J - 1
INFO = 1
*
200 CONTINUE
RETURN
*
* End of ZPSTF2
*
END
*> \brief \b ZPSTRF computes the Cholesky factorization with complete pivoting of a complex Hermitian positive semidefinite matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPSTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpstrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpstrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpstrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION TOL
* INTEGER INFO, LDA, N, RANK
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* DOUBLE PRECISION WORK( 2*N )
* INTEGER PIV( N )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPSTRF computes the Cholesky factorization with complete
*> pivoting of a complex Hermitian positive semidefinite matrix A.
*>
*> The factorization has the form
*> P**T * A * P = U**H * U , if UPLO = 'U',
*> P**T * A * P = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular, and
*> P is stored as vector PIV.
*>
*> This algorithm does not attempt to check that A is positive
*> semidefinite. This version of the algorithm calls level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric 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 symmetric 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 as above.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] PIV
*> \verbatim
*> PIV is INTEGER array, dimension (N)
*> PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
*> \endverbatim
*>
*> \param[out] RANK
*> \verbatim
*> RANK is INTEGER
*> The rank of A given by the number of steps the algorithm
*> completed.
*> \endverbatim
*>
*> \param[in] TOL
*> \verbatim
*> TOL is DOUBLE PRECISION
*> User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )
*> will be used. The algorithm terminates at the (K-1)st step
*> if the pivot <= TOL.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (2*N)
*> Work space.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> < 0: If INFO = -K, the K-th argument had an illegal value,
*> = 0: algorithm completed successfully, and
*> > 0: the matrix A is either rank deficient with computed rank
*> as returned in RANK, or is not positive semidefinite. See
*> Section 7 of LAPACK Working Note #161 for further
*> information.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup pstrf
*
* =====================================================================
SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION TOL
INTEGER INFO, LDA, N, RANK
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
DOUBLE PRECISION WORK( 2*N )
INTEGER PIV( N )
* ..
*
* =====================================================================
*
* .. 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 ..
COMPLEX*16 ZTEMP
DOUBLE PRECISION AJJ, DSTOP, DTEMP
INTEGER I, ITEMP, J, JB, K, NB, PVT
LOGICAL UPPER
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER ILAENV
LOGICAL LSAME, DISNAN
EXTERNAL DLAMCH, ILAENV, LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZGEMV, ZHERK, ZLACGV, ZPSTF2,
$ ZSWAP,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCONJG, MAX, MIN, SQRT, MAXLOC
* ..
* .. 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( 'ZPSTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get block size
*
NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL ZPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK,
$ INFO )
GO TO 230
*
ELSE
*
* Initialize PIV
*
DO 100 I = 1, N
PIV( I ) = I
100 CONTINUE
*
* Compute stopping value
*
DO 110 I = 1, N
WORK( I ) = DBLE( A( I, I ) )
110 CONTINUE
PVT = MAXLOC( WORK( 1:N ), 1 )
AJJ = DBLE( A( PVT, PVT ) )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
RANK = 0
INFO = 1
GO TO 230
END IF
*
* Compute stopping value if not supplied
*
IF( TOL.LT.ZERO ) THEN
DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ
ELSE
DSTOP = TOL
END IF
*
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization P**T * A * P = U**H * U
*
DO 160 K = 1, N, NB
*
* Account for last block not being NB wide
*
JB = MIN( NB, N-K+1 )
*
* Set relevant part of first half of WORK to zero,
* holds dot products
*
DO 120 I = K, N
WORK( I ) = 0
120 CONTINUE
*
DO 150 J = K, K + JB - 1
*
* Find pivot, test for exit, else swap rows and columns
* Update dot products, compute possible pivots which are
* stored in the second half of WORK
*
DO 130 I = J, N
*
IF( J.GT.K ) THEN
WORK( I ) = WORK( I ) +
$ DBLE( DCONJG( A( J-1, I ) )*
$ A( J-1, I ) )
END IF
WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I )
*
130 CONTINUE
*
IF( J.GT.1 ) THEN
ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
PVT = ITEMP + J - 1
AJJ = WORK( N+PVT )
IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 220
END IF
END IF
*
IF( J.NE.PVT ) THEN
*
* Pivot OK, so can now swap pivot rows and columns
*
A( PVT, PVT ) = A( J, J )
CALL ZSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 )
IF( PVT.LT.N )
$ CALL ZSWAP( N-PVT, A( J, PVT+1 ), LDA,
$ A( PVT, PVT+1 ), LDA )
DO 140 I = J + 1, PVT - 1
ZTEMP = DCONJG( A( J, I ) )
A( J, I ) = DCONJG( A( I, PVT ) )
A( I, PVT ) = ZTEMP
140 CONTINUE
A( J, PVT ) = DCONJG( A( J, PVT ) )
*
* Swap dot products and PIV
*
DTEMP = WORK( J )
WORK( J ) = WORK( PVT )
WORK( PVT ) = DTEMP
ITEMP = PIV( PVT )
PIV( PVT ) = PIV( J )
PIV( J ) = ITEMP
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( 'Trans', J-K, N-J, -CONE, A( K,
$ J+1 ),
$ LDA, A( K, 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
*
150 CONTINUE
*
* Update trailing matrix, J already incremented
*
IF( K+JB.LE.N ) THEN
CALL ZHERK( 'Upper', 'Conj Trans', N-J+1, JB, -ONE,
$ A( K, J ), LDA, ONE, A( J, J ), LDA )
END IF
*
160 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization P**T * A * P = L * L**H
*
DO 210 K = 1, N, NB
*
* Account for last block not being NB wide
*
JB = MIN( NB, N-K+1 )
*
* Set relevant part of first half of WORK to zero,
* holds dot products
*
DO 170 I = K, N
WORK( I ) = 0
170 CONTINUE
*
DO 200 J = K, K + JB - 1
*
* Find pivot, test for exit, else swap rows and columns
* Update dot products, compute possible pivots which are
* stored in the second half of WORK
*
DO 180 I = J, N
*
IF( J.GT.K ) THEN
WORK( I ) = WORK( I ) +
$ DBLE( DCONJG( A( I, J-1 ) )*
$ A( I, J-1 ) )
END IF
WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I )
*
180 CONTINUE
*
IF( J.GT.1 ) THEN
ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 )
PVT = ITEMP + J - 1
AJJ = WORK( N+PVT )
IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN
A( J, J ) = AJJ
GO TO 220
END IF
END IF
*
IF( J.NE.PVT ) THEN
*
* Pivot OK, so can now swap pivot rows and columns
*
A( PVT, PVT ) = A( J, J )
CALL ZSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ),
$ LDA )
IF( PVT.LT.N )
$ CALL ZSWAP( N-PVT, A( PVT+1, J ), 1,
$ A( PVT+1, PVT ), 1 )
DO 190 I = J + 1, PVT - 1
ZTEMP = DCONJG( A( I, J ) )
A( I, J ) = DCONJG( A( PVT, I ) )
A( PVT, I ) = ZTEMP
190 CONTINUE
A( PVT, J ) = DCONJG( A( PVT, J ) )
*
*
* Swap dot products and PIV
*
DTEMP = WORK( J )
WORK( J ) = WORK( PVT )
WORK( PVT ) = DTEMP
ITEMP = PIV( PVT )
PIV( PVT ) = PIV( J )
PIV( J ) = ITEMP
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 Trans', N-J, J-K, -CONE,
$ A( J+1, K ), LDA, A( J, K ), 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
*
200 CONTINUE
*
* Update trailing matrix, J already incremented
*
IF( K+JB.LE.N ) THEN
CALL ZHERK( 'Lower', 'No Trans', N-J+1, JB, -ONE,
$ A( J, K ), LDA, ONE, A( J, J ), LDA )
END IF
*
210 CONTINUE
*
END IF
END IF
*
* Ran to completion, A has full rank
*
RANK = N
*
GO TO 230
220 CONTINUE
*
* Rank is the number of steps completed. Set INFO = 1 to signal
* that the factorization cannot be used to solve a system.
*
RANK = J - 1
INFO = 1
*
230 CONTINUE
RETURN
*
* End of ZPSTRF
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zrot.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zrot.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zrot.f">
*> [TXT]</a>
*> \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 CX. 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.
*
*> \ingroup rot
*
* =====================================================================
SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zdrscl.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zdrscl.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zdrscl.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZRSCL( N, A, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX*16 A
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZRSCL multiplies an n-element complex vector x by the complex 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] A
*> \verbatim
*> A is COMPLEX*16
*> The scalar a which is used to divide each component of x.
*> A must not be 0, or the subroutine will divide by zero.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X 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.
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZRSCL( N, A, X, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX*16 A
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION SAFMAX, SAFMIN, OV, AR, AI, ABSR, ABSI, UR, UI
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, ZDSCAL, ZDRSCL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Get machine parameters
*
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
OV = DLAMCH( 'O' )
*
* Initialize constants related to A.
*
AR = DBLE( A )
AI = DIMAG( A )
ABSR = ABS( AR )
ABSI = ABS( AI )
*
IF( AI.EQ.ZERO ) THEN
* If alpha is real, then we can use csrscl
CALL ZDRSCL( N, AR, X, INCX )
*
ELSE IF( AR.EQ.ZERO ) THEN
* If alpha has a zero real part, then we follow the same rules as if
* alpha were real.
IF( ABSI.GT.SAFMAX ) THEN
CALL ZDSCAL( N, SAFMIN, X, INCX )
CALL ZSCAL( N, DCMPLX( ZERO, -SAFMAX / AI ), X, INCX )
ELSE IF( ABSI.LT.SAFMIN ) THEN
CALL ZSCAL( N, DCMPLX( ZERO, -SAFMIN / AI ), X, INCX )
CALL ZDSCAL( N, SAFMAX, X, INCX )
ELSE
CALL ZSCAL( N, DCMPLX( ZERO, -ONE / AI ), X, INCX )
END IF
*
ELSE
* The following numbers can be computed.
* They are the inverse of the real and imaginary parts of 1/alpha.
* Note that a and b are always different from zero.
* NaNs are only possible if either:
* 1. alphaR or alphaI is NaN.
* 2. alphaR and alphaI are both infinite, in which case it makes sense
* to propagate a NaN.
UR = AR + AI * ( AI / AR )
UI = AI + AR * ( AR / AI )
*
IF( (ABS( UR ).LT.SAFMIN).OR.(ABS( UI ).LT.SAFMIN) ) THEN
* This means that both alphaR and alphaI are very small.
CALL ZSCAL( N, DCMPLX( SAFMIN / UR, -SAFMIN / UI ), X,
$ INCX )
CALL ZDSCAL( N, SAFMAX, X, INCX )
ELSE IF( (ABS( UR ).GT.SAFMAX).OR.(ABS( UI ).GT.SAFMAX) ) THEN
IF( (ABSR.GT.OV).OR.(ABSI.GT.OV) ) THEN
* This means that a and b are both Inf. No need for scaling.
CALL ZSCAL( N, DCMPLX( ONE / UR, -ONE / UI ), X,
$ INCX )
ELSE
CALL ZDSCAL( N, SAFMIN, X, INCX )
IF( (ABS( UR ).GT.OV).OR.(ABS( UI ).GT.OV) ) THEN
* Infs were generated. We do proper scaling to avoid them.
IF( ABSR.GE.ABSI ) THEN
* ABS( UR ) <= ABS( UI )
UR = (SAFMIN * AR) + SAFMIN * (AI * ( AI / AR ))
UI = (SAFMIN * AI) + AR * ( (SAFMIN * AR) / AI )
ELSE
* ABS( UR ) > ABS( UI )
UR = (SAFMIN * AR) + AI * ( (SAFMIN * AI) / AR )
UI = (SAFMIN * AI) + SAFMIN * (AR * ( AR / AI ))
END IF
CALL ZSCAL( N, DCMPLX( ONE / UR, -ONE / UI ), X,
$ INCX )
ELSE
CALL ZSCAL( N, DCMPLX( SAFMAX / UR, -SAFMAX / UI ),
$ X, INCX )
END IF
END IF
ELSE
CALL ZSCAL( N, DCMPLX( ONE / UR, -ONE / UI ), X, INCX )
END IF
END IF
*
RETURN
*
* End of ZRSCL
*
END
*> \brief \b ZSPCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zspcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zspcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zspcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPCON estimates the reciprocal of the condition number (in the
*> 1-norm) of a complex symmetric packed matrix A using the
*> factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZSPTRF, stored as a
*> packed triangular matrix.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZSPTRF.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*
*> \ingroup hpcon
*
* =====================================================================
SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IP, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZSPTRS
* ..
* .. 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( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
IP = N*( N+1 ) / 2
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP - I
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
IP = 1
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
$ RETURN
IP = IP + N - I + 1
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
*
CALL ZSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of ZSPCON
*
END
*> \brief \b ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPMV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zspmv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zspmv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zspmv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INCX, INCY, N
* COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), X( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPMV performs the matrix-vector operation
*>
*> y := alpha*A*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are n element vectors and
*> A is an n by n symmetric matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*>
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, ALPHA specifies the scalar alpha.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( N*( N + 1 ) )/2 ).
*> Before entry, with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on.
*> Before entry, with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the N-
*> element vector x.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX*16
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> Unchanged on exit.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hpmv
*
* =====================================================================
SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCX, INCY, N
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), X( * ), Y( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
COMPLEX*16 TEMP1, TEMP2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND.
$ .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = 1
ELSE IF( N.LT.0 ) THEN
INFO = 2
ELSE IF( INCX.EQ.0 ) THEN
INFO = 6
ELSE IF( INCY.EQ.0 ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
$ RETURN
*
* Set up the start points in X and Y.
*
IF( INCX.GT.0 ) THEN
KX = 1
ELSE
KX = 1 - ( N-1 )*INCX
END IF
IF( INCY.GT.0 ) THEN
KY = 1
ELSE
KY = 1 - ( N-1 )*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF( BETA.NE.ONE ) THEN
IF( INCY.EQ.1 ) THEN
IF( BETA.EQ.ZERO ) THEN
DO 10 I = 1, N
Y( I ) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1, N
Y( I ) = BETA*Y( I )
20 CONTINUE
END IF
ELSE
IY = KY
IF( BETA.EQ.ZERO ) THEN
DO 30 I = 1, N
Y( IY ) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1, N
Y( IY ) = BETA*Y( IY )
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF( ALPHA.EQ.ZERO )
$ RETURN
KK = 1
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Form y when AP contains the upper triangle.
*
IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
DO 60 J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
K = KK
DO 50 I = 1, J - 1
Y( I ) = Y( I ) + TEMP1*AP( K )
TEMP2 = TEMP2 + AP( K )*X( I )
K = K + 1
50 CONTINUE
Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK, KK + J - 2
Y( IY ) = Y( IY ) + TEMP1*AP( K )
TEMP2 = TEMP2 + AP( K )*X( IX )
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
DO 100 J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
Y( J ) = Y( J ) + TEMP1*AP( KK )
K = KK + 1
DO 90 I = J + 1, N
Y( I ) = Y( I ) + TEMP1*AP( K )
TEMP2 = TEMP2 + AP( K )*X( I )
K = K + 1
90 CONTINUE
Y( J ) = Y( J ) + ALPHA*TEMP2
KK = KK + ( N-J+1 )
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
Y( JY ) = Y( JY ) + TEMP1*AP( KK )
IX = JX
IY = JY
DO 110 K = KK + 1, KK + N - J
IX = IX + INCX
IY = IY + INCY
Y( IY ) = Y( IY ) + TEMP1*AP( K )
TEMP2 = TEMP2 + AP( K )*X( IX )
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + ( N-J+1 )
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZSPMV
*
END
*> \brief \b ZSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zspr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zspr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zspr.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INCX, N
* COMPLEX*16 ALPHA
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPR performs the symmetric rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a complex scalar, x is an n element vector and A is an
*> n by n symmetric matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*>
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, ALPHA specifies the scalar alpha.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the N-
*> element vector x.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( N*( N + 1 ) )/2 ).
*> Before entry, with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry, with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hpr
*
* =====================================================================
SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCX, N
COMPLEX*16 ALPHA
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IX, J, JX, K, KK, KX
COMPLEX*16 TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND.
$ .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = 1
ELSE IF( N.LT.0 ) THEN
INFO = 2
ELSE IF( INCX.EQ.0 ) THEN
INFO = 5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPR ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
$ RETURN
*
* Set the start point in X if the increment is not unity.
*
IF( INCX.LE.0 ) THEN
KX = 1 - ( N-1 )*INCX
ELSE IF( INCX.NE.1 ) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Form A when upper triangle is stored in AP.
*
IF( INCX.EQ.1 ) THEN
DO 20 J = 1, N
IF( X( J ).NE.ZERO ) THEN
TEMP = ALPHA*X( J )
K = KK
DO 10 I = 1, J - 1
AP( K ) = AP( K ) + X( I )*TEMP
K = K + 1
10 CONTINUE
AP( KK+J-1 ) = AP( KK+J-1 ) + X( J )*TEMP
ELSE
AP( KK+J-1 ) = AP( KK+J-1 )
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1, N
IF( X( JX ).NE.ZERO ) THEN
TEMP = ALPHA*X( JX )
IX = KX
DO 30 K = KK, KK + J - 2
AP( K ) = AP( K ) + X( IX )*TEMP
IX = IX + INCX
30 CONTINUE
AP( KK+J-1 ) = AP( KK+J-1 ) + X( JX )*TEMP
ELSE
AP( KK+J-1 ) = AP( KK+J-1 )
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF( INCX.EQ.1 ) THEN
DO 60 J = 1, N
IF( X( J ).NE.ZERO ) THEN
TEMP = ALPHA*X( J )
AP( KK ) = AP( KK ) + TEMP*X( J )
K = KK + 1
DO 50 I = J + 1, N
AP( K ) = AP( K ) + X( I )*TEMP
K = K + 1
50 CONTINUE
ELSE
AP( KK ) = AP( KK )
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1, N
IF( X( JX ).NE.ZERO ) THEN
TEMP = ALPHA*X( JX )
AP( KK ) = AP( KK ) + TEMP*X( JX )
IX = JX
DO 70 K = KK + 1, KK + N - J
IX = IX + INCX
AP( K ) = AP( K ) + X( IX )*TEMP
70 CONTINUE
ELSE
AP( KK ) = AP( KK )
END IF
JX = JX + INCX
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZSPR
*
END
*> \brief \b ZSPTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsptrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsptrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsptrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPTRF computes the factorization of a complex symmetric matrix A
*> stored in packed format using the Bunch-Kaufman diagonal pivoting
*> method:
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the symmetric matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L, stored as a packed triangular
*> matrix overwriting A (see below for further details).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D.
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \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, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hptrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
*> Company
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
$ KSTEP, KX, NPP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX
COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
EXTERNAL LSAME, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZSCAL, ZSPR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT
* ..
* .. 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' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPTRF', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
KC = ( N-1 )*N / 2 + 1
10 CONTINUE
KNC = KC
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( AP( KC+K-1 ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, AP( KC ), 1 )
COLMAX = CABS1( AP( KC+IMAX-1 ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
ROWMAX = ZERO
JMAX = IMAX
KX = IMAX*( IMAX+1 ) / 2 + IMAX
DO 20 J = IMAX + 1, K
IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = CABS1( AP( KX ) )
JMAX = J
END IF
KX = KX + J
20 CONTINUE
KPC = ( IMAX-1 )*IMAX / 2 + 1
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-1 ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KSTEP.EQ.2 )
$ KNC = KNC - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL ZSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 30 J = KP + 1, KK - 1
KX = KX + J - 1
T = AP( KNC+J-1 )
AP( KNC+J-1 ) = AP( KX )
AP( KX ) = T
30 CONTINUE
T = AP( KNC+KK-1 )
AP( KNC+KK-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+K-2 )
AP( KC+K-2 ) = AP( KC+KP-1 )
AP( KC+KP-1 ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T
*
R1 = CONE / AP( KC+K-1 )
CALL ZSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
*
* Store U(k) in column k
*
CALL ZSCAL( K-1, R1, AP( KC ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T
*
IF( K.GT.2 ) THEN
*
D12 = AP( K-1+( K-1 )*K / 2 )
D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
D11 = AP( K+( K-1 )*K / 2 ) / D12
T = CONE / ( D11*D22-CONE )
D12 = T / D12
*
DO 50 J = K - 2, 1, -1
WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
$ AP( J+( K-1 )*K / 2 ) )
WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
$ AP( J+( K-2 )*( K-1 ) / 2 ) )
DO 40 I = J, 1, -1
AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
$ AP( I+( K-1 )*K / 2 )*WK -
$ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
40 CONTINUE
AP( J+( K-1 )*K / 2 ) = WK
AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
50 CONTINUE
*
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
KC = KNC - K
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
KC = 1
NPP = N*( N+1 ) / 2
60 CONTINUE
KNC = KC
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 110
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( AP( KC ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, AP( KC+1 ), 1 )
COLMAX = CABS1( AP( KC+IMAX-K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*
* Column K is zero: set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
ROWMAX = ZERO
KX = KC + IMAX - K
DO 70 J = K, IMAX - 1
IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
ROWMAX = CABS1( AP( KX ) )
JMAX = J
END IF
KX = KX + N - J
70 CONTINUE
KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, AP( KPC+1 ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KSTEP.EQ.2 )
$ KNC = KNC + N - K + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, AP( KNC+KP-KK+1 ), 1,
$ AP( KPC+1 ),
$ 1 )
KX = KNC + KP - KK
DO 80 J = KK + 1, KP - 1
KX = KX + N - J + 1
T = AP( KNC+J-KK )
AP( KNC+J-KK ) = AP( KX )
AP( KX ) = T
80 CONTINUE
T = AP( KNC )
AP( KNC ) = AP( KPC )
AP( KPC ) = T
IF( KSTEP.EQ.2 ) THEN
T = AP( KC+1 )
AP( KC+1 ) = AP( KC+KP-K )
AP( KC+KP-K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T
*
R1 = CONE / AP( KC )
CALL ZSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
$ AP( KC+N-K+1 ) )
*
* Store L(k) in column K
*
CALL ZSCAL( N-K, R1, AP( KC+1 ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k): columns K and K+1 now hold
*
* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
*
* where L(k) and L(k+1) are the k-th and (k+1)-th columns
* of L
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
*
DO 100 J = K + 2, N
WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
$ AP( J+K*( 2*N-K-1 ) / 2 ) )
WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
$ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
DO 90 I = J, N
AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
$ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
$ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
90 CONTINUE
AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
100 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
KC = KNC + N - K + 2
GO TO 60
*
END IF
*
110 CONTINUE
RETURN
*
* End of ZSPTRF
*
END
*> \brief \b ZSPTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsptri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsptri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsptri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPTRI computes the inverse of a complex symmetric indefinite matrix
*> A in packed storage using the factorization A = U*D*U**T or
*> A = L*D*L**T computed by ZSPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by ZSPTRF,
*> stored as a packed triangular matrix.
*>
*> On exit, if INFO = 0, the (symmetric) inverse of the original
*> matrix, stored as a packed triangular matrix. The j-th column
*> of inv(A) is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
*> if UPLO = 'L',
*> AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZSPTRF.
*> \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
*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hptri
*
* =====================================================================
SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTU
EXTERNAL LSAME, ZDOTU
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZSPMV, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
KP = N*( N+1 ) / 2
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP - INFO
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
KP = 1
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
$ RETURN
KP = KP + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
KCNEXT = KC + K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC+K-1 ) = ONE / AP( KC+K-1 )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
$ AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ ZDOTU( K-1, WORK, 1, AP( KC ), 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = AP( KCNEXT+K-1 )
AK = AP( KC+K-1 ) / T
AKP1 = AP( KCNEXT+K ) / T
AKKP1 = AP( KCNEXT+K-1 ) / T
D = T*( AK*AKP1-ONE )
AP( KC+K-1 ) = AKP1 / D
AP( KCNEXT+K ) = AK / D
AP( KCNEXT+K-1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
$ AP( KC ),
$ 1 )
AP( KC+K-1 ) = AP( KC+K-1 ) -
$ ZDOTU( K-1, WORK, 1, AP( KC ), 1 )
AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
$ ZDOTU( K-1, AP( KC ), 1,
$ AP( KCNEXT ),
$ 1 )
CALL ZCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
$ AP( KCNEXT ), 1 )
AP( KCNEXT+K ) = AP( KCNEXT+K ) -
$ ZDOTU( K-1, WORK, 1, AP( KCNEXT ),
$ 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT + K + 1
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
KPC = ( KP-1 )*KP / 2 + 1
CALL ZSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
KX = KPC + KP - 1
DO 40 J = KP + 1, K - 1
KX = KX + J - 1
TEMP = AP( KC+J-1 )
AP( KC+J-1 ) = AP( KX )
AP( KX ) = TEMP
40 CONTINUE
TEMP = AP( KC+K-1 )
AP( KC+K-1 ) = AP( KPC+KP-1 )
AP( KPC+KP-1 ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC+K+K-1 )
AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
AP( KC+K+KP-1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
KC = KCNEXT
GO TO 30
50 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
NPP = N*( N+1 ) / 2
K = N
KC = NPP
60 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 80
*
KCNEXT = KC - ( N-K+2 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
AP( KC ) = ONE / AP( KC )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - ZDOTU( N-K, WORK, 1, AP( KC+1 ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = AP( KCNEXT+1 )
AK = AP( KCNEXT ) / T
AKP1 = AP( KC ) / T
AKKP1 = AP( KCNEXT+1 ) / T
D = T*( AK*AKP1-ONE )
AP( KCNEXT ) = AKP1 / D
AP( KC ) = AK / D
AP( KCNEXT+1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK,
$ 1,
$ ZERO, AP( KC+1 ), 1 )
AP( KC ) = AP( KC ) - ZDOTU( N-K, WORK, 1, AP( KC+1 ),
$ 1 )
AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
$ ZDOTU( N-K, AP( KC+1 ), 1,
$ AP( KCNEXT+2 ), 1 )
CALL ZCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK,
$ 1,
$ ZERO, AP( KCNEXT+2 ), 1 )
AP( KCNEXT ) = AP( KCNEXT ) -
$ ZDOTU( N-K, WORK, 1, AP( KCNEXT+2 ),
$ 1 )
END IF
KSTEP = 2
KCNEXT = KCNEXT - ( N-K+3 )
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
KX = KC + KP - K
DO 70 J = K + 1, KP - 1
KX = KX + N - J + 1
TEMP = AP( KC+J-K )
AP( KC+J-K ) = AP( KX )
AP( KX ) = TEMP
70 CONTINUE
TEMP = AP( KC )
AP( KC ) = AP( KPC )
AP( KPC ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = AP( KC-N+K-1 )
AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
AP( KC-N+KP-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
KC = KCNEXT
GO TO 60
80 CONTINUE
END IF
*
RETURN
*
* End of ZSPTRI
*
END
*> \brief \b ZSPTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSPTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsptrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsptrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsptrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSPTRS solves a system of linear equations A*X = B with a complex
*> symmetric matrix A stored in packed format using the factorization
*> A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZSPTRF, stored as a
*> packed triangular matrix.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> Details of the interchanges and the block structure of D
*> as determined by ZSPTRF.
*> \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.
*
*> \ingroup hptrs
*
* =====================================================================
SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, K, KC, KP
COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
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( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**T.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
KC = KC - K
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL ZSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL ZGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
$ B( 1, 1 ), LDB )
CALL ZGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
$ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+K-2 )
AKM1 = AP( KC-1 ) / AKM1K
AK = AP( KC+K-1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
KC = KC - K + 1
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**T*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**T(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + K
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ AP( KC ),
$ 1, ONE, B( K, 1 ), LDB )
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC + 2*K + 1
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**T.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
KC = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL ZSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
KC = KC + N - K + 1
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K,
$ 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = AP( KC+1 )
AKM1 = AP( KC ) / AKM1K
AK = AP( KC+N-K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
KC = KC + 2*( N-K ) + 1
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**T*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
KC = N*( N+1 ) / 2 + 1
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
KC = KC - ( N-K+1 )
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**T(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
KC = KC - ( N-K+2 )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of ZSPTRS
*
END
*> \brief \b ZSTEDC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEDC + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zstedc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zstedc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zstedc.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
* LRWORK, IWORK, LIWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
*> symmetric tridiagonal matrix using the divide and conquer 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.
*> = 'I': Compute eigenvectors of tridiagonal matrix also.
*> = 'V': Compute eigenvectors of original Hermitian matrix
*> also. On entry, Z contains the unitary matrix used
*> to reduce the original matrix to tridiagonal form.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal 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 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.
*> If eigenvectors are desired, then LDZ >= max(1,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.
*> If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
*> If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
*> Note that for COMPZ = 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LWORK need
*> only be 1.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal sizes of the WORK, RWORK and
*> IWORK arrays, returns these values as the first entries of
*> the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of the array RWORK.
*> If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
*> If COMPZ = 'V' and N > 1, LRWORK must be at least
*> 1 + 3*N + 2*N*lg N + 4*N**2 ,
*> where lg( N ) = smallest integer k such
*> that 2**k >= N.
*> If COMPZ = 'I' and N > 1, LRWORK must be at least
*> 1 + 4*N + 2*N**2 .
*> Note that for COMPZ = 'I' or 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LRWORK
*> need only be max(1,2*(N-1)).
*>
*> If LRWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*> LIWORK is INTEGER
*> The dimension of the array IWORK.
*> If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
*> If COMPZ = 'V' or N > 1, LIWORK must be at least
*> 6 + 6*N + 5*N*lg N.
*> If COMPZ = 'I' or N > 1, LIWORK must be at least
*> 3 + 5*N .
*> Note that for COMPZ = 'I' or 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LIWORK
*> need only be 1.
*>
*> If LIWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK 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.
*> > 0: The algorithm failed to compute an eigenvalue 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.
*
*> \ingroup stedc
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
$ LRWMIN, LWMIN, M, SMLSIZ, START
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF,
$ XERBLA,
$ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
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.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 2*( N - 1 )
ELSE IF( ICOMPZ.EQ.1 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWMIN = N*N
LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1
LRWMIN = 1 + 4*N + 2*N**2
LIWMIN = 3 + 5*N
END IF
WORK( 1 ) = LWMIN
RWORK( 1 ) = REAL( LRWMIN )
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEDC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 70
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
*
ELSE
*
* If COMPZ = 'I', we simply call DSTEDC instead.
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
LL = N*N + 1
CALL DSTEDC( 'I', N, D, E, RWORK, N,
$ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
DO 20 J = 1, N
DO 10 I = 1, N
Z( I, J ) = RWORK( ( J-1 )*N+I )
10 CONTINUE
20 CONTINUE
GO TO 70
END IF
*
* From now on, only option left to be handled is COMPZ = 'V',
* i.e. ICOMPZ = 1.
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 70
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
30 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
40 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 40
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ),
$ M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1,
$ E( START ),
$ M-1, INFO )
*
CALL ZLAED0( N, M, D( START ), E( START ), Z( 1,
$ START ),
$ LDZ, WORK, N, RWORK, IWORK, INFO )
IF( INFO.GT.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 70
END IF
*
* Scale back.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ),
$ M,
$ INFO )
*
ELSE
CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
$ RWORK( M*M+1 ), INFO )
CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK,
$ N,
$ RWORK( M*M+1 ) )
CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
IF( INFO.GT.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 70
END IF
END IF
*
START = FINISH + 1
GO TO 30
END IF
*
* endwhile
*
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 60 II = 2, N
I = II - 1
K = I
P = D( I )
DO 50 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
50 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
60 CONTINUE
END IF
*
70 CONTINUE
WORK( 1 ) = LWMIN
RWORK( 1 ) = REAL( LRWMIN )
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of ZSTEDC
*
END
*> \brief \b ZSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEQR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsteqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsteqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsteqr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup steqr
*
* =====================================================================
SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZSYCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsycon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsycon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsycon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYCON estimates the reciprocal of the condition number (in the
*> 1-norm) of a complex symmetric matrix A using the factorization
*> A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \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 block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZSYTRF.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZSYTRF.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> The 1-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/(ANORM * AINVNM), where AINVNM is an
*> estimate of the 1-norm of inv(A) computed in this routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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.
*
*> \ingroup hecon
*
* =====================================================================
SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, KASE
DOUBLE PRECISION AINVNM
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZSYTRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSYCON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.LE.ZERO ) THEN
RETURN
END IF
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 I = N, 1, -1
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 I = 1, N
IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
*
* Estimate the 1-norm of the inverse.
*
KASE = 0
30 CONTINUE
CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
*
* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
*
CALL ZSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
GO TO 30
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO )
$ RCOND = ( ONE / AINVNM ) / ANORM
*
RETURN
*
* End of ZSYCON
*
END
*> \brief \b ZSYMV computes a matrix-vector product for a complex symmetric matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYMV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsymv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsymv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsymv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INCX, INCY, LDA, N
* COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), X( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYMV performs the matrix-vector operation
*>
*> y := alpha*A*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are n element vectors and
*> A is an n by n symmetric matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the array A is to be referenced as
*> follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of A
*> is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of A
*> is to be referenced.
*>
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, ALPHA specifies the scalar alpha.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N )
*> Before entry, with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the symmetric matrix and the strictly
*> lower triangular part of A is not referenced.
*> Before entry, with UPLO = 'L' or 'l', the leading n by n
*> lower triangular part of the array A must contain the lower
*> triangular part of the symmetric matrix and the strictly
*> upper triangular part of A is not referenced.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, N ).
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the N-
*> element vector x.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX*16
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> Unchanged on exit.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hemv
*
* =====================================================================
SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
$ INCY )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCX, INCY, LDA, N
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
COMPLEX*16 TEMP1, TEMP2
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .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 = 5
ELSE IF( INCX.EQ.0 ) THEN
INFO = 7
ELSE IF( INCY.EQ.0 ) THEN
INFO = 10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSYMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
$ RETURN
*
* Set up the start points in X and Y.
*
IF( INCX.GT.0 ) THEN
KX = 1
ELSE
KX = 1 - ( N-1 )*INCX
END IF
IF( INCY.GT.0 ) THEN
KY = 1
ELSE
KY = 1 - ( N-1 )*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
* First form y := beta*y.
*
IF( BETA.NE.ONE ) THEN
IF( INCY.EQ.1 ) THEN
IF( BETA.EQ.ZERO ) THEN
DO 10 I = 1, N
Y( I ) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1, N
Y( I ) = BETA*Y( I )
20 CONTINUE
END IF
ELSE
IY = KY
IF( BETA.EQ.ZERO ) THEN
DO 30 I = 1, N
Y( IY ) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1, N
Y( IY ) = BETA*Y( IY )
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF( ALPHA.EQ.ZERO )
$ RETURN
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Form y when A is stored in upper triangle.
*
IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
DO 60 J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
DO 50 I = 1, J - 1
Y( I ) = Y( I ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( I )
50 CONTINUE
Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 I = 1, J - 1
Y( IY ) = Y( IY ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( IX )
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in lower triangle.
*
IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
DO 100 J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
Y( J ) = Y( J ) + TEMP1*A( J, J )
DO 90 I = J + 1, N
Y( I ) = Y( I ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( I )
90 CONTINUE
Y( J ) = Y( J ) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
Y( JY ) = Y( JY ) + TEMP1*A( J, J )
IX = JX
IY = JY
DO 110 I = J + 1, N
IX = IX + INCX
IY = IY + INCY
Y( IY ) = Y( IY ) + TEMP1*A( I, J )
TEMP2 = TEMP2 + A( I, J )*X( IX )
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZSYMV
*
END
*> \brief \b ZSYR performs the symmetric rank-1 update of a complex symmetric matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsyr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsyr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsyr.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INCX, LDA, N
* COMPLEX*16 ALPHA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYR performs the symmetric rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a complex scalar, x is an n element vector and A is an
*> n by n symmetric matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the array A is to be referenced as
*> follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of A
*> is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of A
*> is to be referenced.
*>
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, ALPHA specifies the scalar alpha.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the N-
*> element vector x.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N )
*> Before entry, with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the symmetric matrix and the strictly
*> lower triangular part of A is not referenced. On exit, the
*> upper triangular part of the array A is overwritten by the
*> upper triangular part of the updated matrix.
*> Before entry, with UPLO = 'L' or 'l', the leading n by n
*> lower triangular part of the array A must contain the lower
*> triangular part of the symmetric matrix and the strictly
*> upper triangular part of A is not referenced. On exit, the
*> lower triangular part of the array A is overwritten by the
*> lower triangular part of the updated matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, N ).
*> Unchanged on exit.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup her
*
* =====================================================================
SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INCX, LDA, N
COMPLEX*16 ALPHA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, INFO, IX, J, JX, KX
COMPLEX*16 TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( .NOT.LSAME( UPLO, 'U' ) .AND.
$ .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = 1
ELSE IF( N.LT.0 ) THEN
INFO = 2
ELSE IF( INCX.EQ.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = 7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSYR ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
$ RETURN
*
* Set the start point in X if the increment is not unity.
*
IF( INCX.LE.0 ) THEN
KX = 1 - ( N-1 )*INCX
ELSE IF( INCX.NE.1 ) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Form A when A is stored in upper triangle.
*
IF( INCX.EQ.1 ) THEN
DO 20 J = 1, N
IF( X( J ).NE.ZERO ) THEN
TEMP = ALPHA*X( J )
DO 10 I = 1, J
A( I, J ) = A( I, J ) + X( I )*TEMP
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1, N
IF( X( JX ).NE.ZERO ) THEN
TEMP = ALPHA*X( JX )
IX = KX
DO 30 I = 1, J
A( I, J ) = A( I, J ) + X( IX )*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF( INCX.EQ.1 ) THEN
DO 60 J = 1, N
IF( X( J ).NE.ZERO ) THEN
TEMP = ALPHA*X( J )
DO 50 I = J, N
A( I, J ) = A( I, J ) + X( I )*TEMP
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1, N
IF( X( JX ).NE.ZERO ) THEN
TEMP = ALPHA*X( JX )
IX = JX
DO 70 I = J, N
A( I, J ) = A( I, J ) + X( IX )*TEMP
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZSYR
*
END
*> \brief \b ZSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYTF2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytf2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytf2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytf2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYTF2 computes the factorization of a complex symmetric matrix A
*> using the Bunch-Kaufman diagonal pivoting method:
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, U**T is the transpose of U, and D is symmetric and
*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
*>
*> 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
*> symmetric 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 symmetric 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, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \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)
*> Details of the interchanges and the block structure of D.
*>
*> If UPLO = 'U':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns
*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block.
*>
*> If UPLO = 'L':
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*>
*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns
*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
*> is a 2-by-2 diagonal block.
*> \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, D(k,k) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hetf2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> 09-29-06 - patch from
*> Bobby Cheng, MathWorks
*>
*> Replace l.209 and l.377
*> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
*> by
*> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
*>
*> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
*> Company
*> \endverbatim
*
* =====================================================================
SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION EIGHT, SEVTEN
PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX
COMPLEX*16 D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z
* ..
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IZAMAX
EXTERNAL DISNAN, LSAME, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZSCAL, ZSWAP, ZSYR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
* ..
* .. 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( 'ZSYTF2', -INFO )
RETURN
END IF
*
* Initialize ALPHA for use in choosing pivot block size.
*
ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.GT.1 ) THEN
IMAX = IZAMAX( K-1, A( 1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
IF( IMAX.GT.1 ) THEN
JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K-1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K - KSTEP + 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the leading
* submatrix A(1:k,1:k)
*
CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K-1, K )
A( K-1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the leading submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = U(k)*D(k)
*
* where U(k) is the k-th column of U
*
* Perform a rank-1 update of A(1:k-1,1:k-1) as
*
* A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T
*
R1 = CONE / A( K, K )
CALL ZSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
*
* Store U(k) in column k
*
CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
ELSE
*
* 2-by-2 pivot block D(k): columns k and k-1 now hold
*
* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
*
* where U(k) and U(k-1) are the k-th and (k-1)-th columns
* of U
*
* Perform a rank-2 update of A(1:k-2,1:k-2) as
*
* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T
*
IF( K.GT.2 ) THEN
*
D12 = A( K-1, K )
D22 = A( K-1, K-1 ) / D12
D11 = A( K, K ) / D12
T = CONE / ( D11*D22-CONE )
D12 = T / D12
*
DO 30 J = K - 2, 1, -1
WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
WK = D12*( D22*A( J, K )-A( J, K-1 ) )
DO 20 I = J, 1, -1
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K-1 )*WKM1
20 CONTINUE
A( J, K ) = WK
A( J, K-1 ) = WKM1
30 CONTINUE
*
END IF
*
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K-1 ) = -KP
END IF
*
* Decrease K and return to the start of the main loop
*
K = K - KSTEP
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 70
KSTEP = 1
*
* Determine rows and columns to be interchanged and whether
* a 1-by-1 or 2-by-2 pivot block will be used
*
ABSAKK = CABS1( A( K, K ) )
*
* IMAX is the row-index of the largest off-diagonal element in
* column K, and COLMAX is its absolute value.
* Determine both COLMAX and IMAX.
*
IF( K.LT.N ) THEN
IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
COLMAX = CABS1( A( IMAX, K ) )
ELSE
COLMAX = ZERO
END IF
*
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN
*
* Column K is zero or underflow, or contains a NaN:
* set INFO and continue
*
IF( INFO.EQ.0 )
$ INFO = K
KP = K
ELSE
IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE
*
* JMAX is the column-index of the largest off-diagonal
* element in row IMAX, and ROWMAX is its absolute value
*
JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
ROWMAX = CABS1( A( IMAX, JMAX ) )
IF( IMAX.LT.N ) THEN
JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
$ 1 )
ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
END IF
*
IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
*
* no interchange, use 1-by-1 pivot block
*
KP = K
ELSE IF( CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
*
* interchange rows and columns K and IMAX, use 1-by-1
* pivot block
*
KP = IMAX
ELSE
*
* interchange rows and columns K+1 and IMAX, use 2-by-2
* pivot block
*
KP = IMAX
KSTEP = 2
END IF
END IF
*
KK = K + KSTEP - 1
IF( KP.NE.KK ) THEN
*
* Interchange rows and columns KK and KP in the trailing
* submatrix A(k:n,k:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ),
$ 1 )
CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
$ LDA )
T = A( KK, KK )
A( KK, KK ) = A( KP, KP )
A( KP, KP ) = T
IF( KSTEP.EQ.2 ) THEN
T = A( K+1, K )
A( K+1, K ) = A( KP, K )
A( KP, K ) = T
END IF
END IF
*
* Update the trailing submatrix
*
IF( KSTEP.EQ.1 ) THEN
*
* 1-by-1 pivot block D(k): column k now holds
*
* W(k) = L(k)*D(k)
*
* where L(k) is the k-th column of L
*
IF( K.LT.N ) THEN
*
* Perform a rank-1 update of A(k+1:n,k+1:n) as
*
* A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T
*
R1 = CONE / A( K, K )
CALL ZSYR( UPLO, N-K, -R1, A( K+1, K ), 1,
$ A( K+1, K+1 ), LDA )
*
* Store L(k) in column K
*
CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
END IF
ELSE
*
* 2-by-2 pivot block D(k)
*
IF( K.LT.N-1 ) THEN
*
* Perform a rank-2 update of A(k+2:n,k+2:n) as
*
* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T
* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T
*
* where L(k) and L(k+1) are the k-th and (k+1)-th
* columns of L
*
D21 = A( K+1, K )
D11 = A( K+1, K+1 ) / D21
D22 = A( K, K ) / D21
T = CONE / ( D11*D22-CONE )
D21 = T / D21
*
DO 60 J = K + 2, N
WK = D21*( D11*A( J, K )-A( J, K+1 ) )
WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
DO 50 I = J, N
A( I, J ) = A( I, J ) - A( I, K )*WK -
$ A( I, K+1 )*WKP1
50 CONTINUE
A( J, K ) = WK
A( J, K+1 ) = WKP1
60 CONTINUE
END IF
END IF
END IF
*
* Store details of the interchanges in IPIV
*
IF( KSTEP.EQ.1 ) THEN
IPIV( K ) = KP
ELSE
IPIV( K ) = -KP
IPIV( K+1 ) = -KP
END IF
*
* Increase K and return to the start of the main loop
*
K = K + KSTEP
GO TO 40
*
END IF
*
70 CONTINUE
RETURN
*
* End of ZSYTF2
*
END
*> \brief \b ZSYTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYTRF + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrf.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrf.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrf.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYTRF computes the factorization of a complex symmetric matrix A
*> using the Bunch-Kaufman diagonal pivoting method. The form of the
*> factorization is
*>
*> A = U*D*U**T or A = L*D*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.
*>
*> This is the blocked 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 symmetric 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, the block diagonal matrix D and the multipliers used
*> to obtain the factor U or L (see below for further details).
*> \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)
*> Details of the interchanges and the block structure of D.
*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were
*> interchanged and D(k,k) is a 1-by-1 diagonal block.
*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
*> \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 WORK. LWORK >=1. For best performance
*> LWORK >= N*NB, where NB is the block size 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] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization
*> has been completed, but the block diagonal matrix D 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.
*
*> \ingroup hetrf
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', then A = U*D*U**T, where
*> U = P(n)*U(n)* ... *P(k)U(k)* ...,
*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to
*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I v 0 ) k-s
*> U(k) = ( 0 I 0 ) s
*> ( 0 0 I ) n-k
*> k-s s n-k
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
*> and A(k,k), and v overwrites A(1:k-2,k-1:k).
*>
*> If UPLO = 'L', then A = L*D*L**T, where
*> L = P(1)*L(1)* ... *P(k)*L(k)* ...,
*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
*> that if the diagonal block D(k) is of order s (s = 1 or 2), then
*>
*> ( I 0 0 ) k-1
*> L(k) = ( 0 I 0 ) s
*> ( 0 v I ) n-k-s+1
*> k-1 s n-k-s+1
*>
*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLASYF, ZSYTF2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. 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 = -7
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size
*
NB = ILAENV( 1, 'ZSYTRF', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, N*NB )
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSYTRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF', UPLO, N, -1, -1,
$ -1 ) )
END IF
ELSE
IWS = 1
END IF
IF( NB.LT.NBMIN )
$ NB = N
*
IF( UPPER ) THEN
*
* Factorize A as U*D*U**T using the upper triangle of A
*
* K is the main loop index, decreasing from N to 1 in steps of
* KB, where KB is the number of columns factorized by ZLASYF;
* KB is either NB or NB-1, or K for the last block
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop
*
IF( K.LT.1 )
$ GO TO 40
*
IF( K.GT.NB ) THEN
*
* Factorize columns k-kb+1:k of A and use blocked code to
* update columns 1:k-kb
*
CALL ZLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N,
$ IINFO )
ELSE
*
* Use unblocked code to factorize columns 1:k of A
*
CALL ZSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
KB = K
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* Decrease K and return to the start of the main loop
*
K = K - KB
GO TO 10
*
ELSE
*
* Factorize A as L*D*L**T using the lower triangle of A
*
* K is the main loop index, increasing from 1 to N in steps of
* KB, where KB is the number of columns factorized by ZLASYF;
* KB is either NB or NB-1, or N-K+1 for the last block
*
K = 1
20 CONTINUE
*
* If K > N, exit from loop
*
IF( K.GT.N )
$ GO TO 40
*
IF( K.LE.N-NB ) THEN
*
* Factorize columns k:k+kb-1 of A and use blocked code to
* update columns k+kb:n
*
CALL ZLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA,
$ IPIV( K ),
$ WORK, N, IINFO )
ELSE
*
* Use unblocked code to factorize columns k:n of A
*
CALL ZSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ),
$ IINFO )
KB = N - K + 1
END IF
*
* Set INFO on the first occurrence of a zero pivot
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + K - 1
*
* Adjust IPIV
*
DO 30 J = K, K + KB - 1
IF( IPIV( J ).GT.0 ) THEN
IPIV( J ) = IPIV( J ) + K - 1
ELSE
IPIV( J ) = IPIV( J ) - K + 1
END IF
30 CONTINUE
*
* Increase K and return to the start of the main loop
*
K = K + KB
GO TO 20
*
END IF
*
40 CONTINUE
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZSYTRF
*
END
*> \brief \b ZSYTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYTRI computes the inverse of a complex symmetric indefinite matrix
*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by
*> ZSYTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \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 block diagonal matrix D and the multipliers
*> used to obtain the factor U or L as computed by ZSYTRF.
*>
*> On exit, if INFO = 0, the (symmetric) inverse of the original
*> matrix. If UPLO = 'U', the upper triangular part of the
*> inverse is formed and the part of A below the diagonal is not
*> referenced; if UPLO = 'L' the lower triangular part of the
*> inverse is formed and the part of A above the diagonal is
*> not referenced.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZSYTRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 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, D(i,i) = 0; the matrix is singular and its
*> inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hetri
*
* =====================================================================
SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KP, KSTEP
COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTU
EXTERNAL LSAME, ZDOTU
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZSWAP, ZSYMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. 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( 'ZSYTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check that the diagonal matrix D is nonsingular.
*
IF( UPPER ) THEN
*
* Upper triangular storage: examine D from bottom to top
*
DO 10 INFO = N, 1, -1
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
*
* Lower triangular storage: examine D from top to bottom.
*
DO 20 INFO = 1, N
IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
$ RETURN
20 CONTINUE
END IF
INFO = 0
*
IF( UPPER ) THEN
*
* Compute inv(A) from the factorization A = U*D*U**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
30 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 40
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1,
$ K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = A( K, K+1 )
AK = A( K, K ) / T
AKP1 = A( K+1, K+1 ) / T
AKKP1 = A( K, K+1 ) / T
D = T*( AK*AKP1-ONE )
A( K, K ) = AKP1 / D
A( K+1, K+1 ) = AK / D
A( K, K+1 ) = -AKKP1 / D
*
* Compute columns K and K+1 of the inverse.
*
IF( K.GT.1 ) THEN
CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K ), 1 )
A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1,
$ K ),
$ 1 )
A( K, K+1 ) = A( K, K+1 ) -
$ ZDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ),
$ 1 )
CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
$ A( 1, K+1 ), 1 )
A( K+1, K+1 ) = A( K+1, K+1 ) -
$ ZDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the leading
* submatrix A(1:k+1,1:k+1)
*
CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K+1 )
A( K, K+1 ) = A( KP, K+1 )
A( KP, K+1 ) = TEMP
END IF
END IF
*
K = K + KSTEP
GO TO 30
40 CONTINUE
*
ELSE
*
* Compute inv(A) from the factorization A = L*D*L**T.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
50 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 60
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Invert the diagonal block.
*
A( K, K ) = ONE / A( K, K )
*
* Compute column K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK,
$ 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1,
$ K ),
$ 1 )
END IF
KSTEP = 1
ELSE
*
* 2 x 2 diagonal block
*
* Invert the diagonal block.
*
T = A( K, K-1 )
AK = A( K-1, K-1 ) / T
AKP1 = A( K, K ) / T
AKKP1 = A( K, K-1 ) / T
D = T*( AK*AKP1-ONE )
A( K-1, K-1 ) = AKP1 / D
A( K, K ) = AK / D
A( K, K-1 ) = -AKKP1 / D
*
* Compute columns K-1 and K of the inverse.
*
IF( K.LT.N ) THEN
CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK,
$ 1,
$ ZERO, A( K+1, K ), 1 )
A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1,
$ K ),
$ 1 )
A( K, K-1 ) = A( K, K-1 ) -
$ ZDOTU( N-K, A( K+1, K ), 1, A( K+1,
$ K-1 ),
$ 1 )
CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK,
$ 1,
$ ZERO, A( K+1, K-1 ), 1 )
A( K-1, K-1 ) = A( K-1, K-1 ) -
$ ZDOTU( N-K, WORK, 1, A( K+1, K-1 ),
$ 1 )
END IF
KSTEP = 2
END IF
*
KP = ABS( IPIV( K ) )
IF( KP.NE.K ) THEN
*
* Interchange rows and columns K and KP in the trailing
* submatrix A(k-1:n,k-1:n)
*
IF( KP.LT.N )
$ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
TEMP = A( K, K )
A( K, K ) = A( KP, KP )
A( KP, KP ) = TEMP
IF( KSTEP.EQ.2 ) THEN
TEMP = A( K, K-1 )
A( K, K-1 ) = A( KP, K-1 )
A( KP, K-1 ) = TEMP
END IF
END IF
*
K = K - KSTEP
GO TO 50
60 CONTINUE
END IF
*
RETURN
*
* End of ZSYTRI
*
END
*> \brief \b ZSYTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSYTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSYTRS solves a system of linear equations A*X = B with a complex
*> symmetric matrix A using the factorization A = U*D*U**T or
*> A = L*D*L**T computed by ZSYTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the details of the factorization are stored
*> as an upper or lower triangular matrix.
*> = 'U': Upper triangular, form is A = U*D*U**T;
*> = 'L': Lower triangular, form is A = L*D*L**T.
*> \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 block diagonal matrix D and the multipliers used to
*> obtain the factor U or L as computed by ZSYTRF.
*> \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)
*> Details of the interchanges and the block structure of D
*> as determined by ZSYTRF.
*> \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.
*
*> \ingroup hetrs
*
* =====================================================================
SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
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 UPPER
INTEGER J, K, KP
COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
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( 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( 'ZSYTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Solve A*X = B, where A = U*D*U**T.
*
* First solve U*D*X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
10 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 30
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB,
$ B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL ZSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K-1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K-1 )
$ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(U(K)), where U(K) is the transformation
* stored in columns K-1 and K of A.
*
CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ),
$ LDB,
$ B( 1, 1 ), LDB )
CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
$ LDB, B( 1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K-1, K )
AKM1 = A( K-1, K-1 ) / AKM1K
AK = A( K, K ) / AKM1K
DENOM = AKM1*AK - ONE
DO 20 J = 1, NRHS
BKM1 = B( K-1, J ) / AKM1K
BK = B( K, J ) / AKM1K
B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
20 CONTINUE
K = K - 2
END IF
*
GO TO 10
30 CONTINUE
*
* Next solve U**T *X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
40 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 50
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(U**T(K)), where U(K) is the transformation
* stored in column K of A.
*
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1,
$ K ),
$ 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation
* stored in columns K and K+1 of A.
*
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1,
$ K ),
$ 1, ONE, B( K, 1 ), LDB )
CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
$ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K + 2
END IF
*
GO TO 40
50 CONTINUE
*
ELSE
*
* Solve A*X = B, where A = L*D*L**T.
*
* First solve L*D*X = B, overwriting B with X.
*
* K is the main loop index, increasing from 1 to N in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = 1
60 CONTINUE
*
* If K > N, exit from loop.
*
IF( K.GT.N )
$ GO TO 80
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K,
$ 1 ),
$ LDB, B( K+1, 1 ), LDB )
*
* Multiply by the inverse of the diagonal block.
*
CALL ZSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
K = K + 1
ELSE
*
* 2 x 2 diagonal block
*
* Interchange rows K+1 and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K+1 )
$ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
* Multiply by inv(L(K)), where L(K) is the transformation
* stored in columns K and K+1 of A.
*
IF( K.LT.N-1 ) THEN
CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K,
$ 1 ),
$ LDB, B( K+2, 1 ), LDB )
CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
$ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
END IF
*
* Multiply by the inverse of the diagonal block.
*
AKM1K = A( K+1, K )
AKM1 = A( K, K ) / AKM1K
AK = A( K+1, K+1 ) / AKM1K
DENOM = AKM1*AK - ONE
DO 70 J = 1, NRHS
BKM1 = B( K, J ) / AKM1K
BK = B( K+1, J ) / AKM1K
B( K, J ) = ( AK*BKM1-BK ) / DENOM
B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
70 CONTINUE
K = K + 2
END IF
*
GO TO 60
80 CONTINUE
*
* Next solve L**T *X = B, overwriting B with X.
*
* K is the main loop index, decreasing from N to 1 in steps of
* 1 or 2, depending on the size of the diagonal blocks.
*
K = N
90 CONTINUE
*
* If K < 1, exit from loop.
*
IF( K.LT.1 )
$ GO TO 100
*
IF( IPIV( K ).GT.0 ) THEN
*
* 1 x 1 diagonal block
*
* Multiply by inv(L**T(K)), where L(K) is the transformation
* stored in column K of A.
*
IF( K.LT.N )
$ CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
*
* Interchange rows K and IPIV(K).
*
KP = IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 1
ELSE
*
* 2 x 2 diagonal block
*
* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation
* stored in columns K-1 and K of A.
*
IF( K.LT.N ) THEN
CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
$ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
$ LDB )
END IF
*
* Interchange rows K and -IPIV(K).
*
KP = -IPIV( K )
IF( KP.NE.K )
$ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
K = K - 2
END IF
*
GO TO 90
100 CONTINUE
END IF
*
RETURN
*
* End of ZSYTRS
*
END
*> \brief \b ZTGEVC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGEVC + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgevc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgevc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgevc.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
* LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, SIDE
* INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
* $ VR( LDVR, * ), WORK( * )
* ..
*
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGEVC computes some or all of the right and/or left eigenvectors of
*> a pair of complex matrices (S,P), where S and P are upper triangular.
*> Matrix pairs of this type are produced by the generalized Schur
*> factorization of a complex matrix pair (A,B):
*>
*> A = Q*S*Z**H, B = Q*P*Z**H
*>
*> as computed by ZGGHRD + ZHGEQZ.
*>
*> The right eigenvector x and the left eigenvector y of (S,P)
*> corresponding to an eigenvalue w are defined by:
*>
*> S*x = w*P*x, (y**H)*S = w*(y**H)*P,
*>
*> where y**H denotes the conjugate transpose of y.
*> The eigenvalues are not input to this routine, but are computed
*> directly from the diagonal elements of S and P.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of (S,P), or the products Z*X and/or Q*Y,
*> where Z and Q are input matrices.
*> If Q and Z are the unitary factors from the generalized Schur
*> factorization of a matrix pair (A,B), then Z*X and Q*Y
*> are the matrices of right and left eigenvectors of (A,B).
*> \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 by the matrices in VR and/or VL;
*> = 'S': compute selected right and/or left eigenvectors,
*> specified 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 matrices S and P. N >= 0.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16 array, dimension (LDS,N)
*> The upper triangular matrix S from a generalized Schur
*> factorization, as computed by ZHGEQZ.
*> \endverbatim
*>
*> \param[in] LDS
*> \verbatim
*> LDS is INTEGER
*> The leading dimension of array S. LDS >= max(1,N).
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*> P is COMPLEX*16 array, dimension (LDP,N)
*> The upper triangular matrix P from a generalized Schur
*> factorization, as computed by ZHGEQZ. P must have real
*> diagonal elements.
*> \endverbatim
*>
*> \param[in] LDP
*> \verbatim
*> LDP is INTEGER
*> The leading dimension of array P. LDP >= 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 left Schur vectors returned by ZHGEQZ).
*> On exit, if SIDE = 'L' or 'B', VL contains:
*> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
*> if HOWMNY = 'B', the matrix Q*Y;
*> if HOWMNY = 'S', the left eigenvectors of (S,P) 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 array VL. LDVL >= 1, and if
*> SIDE = 'L' or 'l' or 'B' 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 Z (usually the unitary matrix Z
*> of right Schur vectors returned by ZHGEQZ).
*> On exit, if SIDE = 'R' or 'B', VR contains:
*> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
*> if HOWMNY = 'B', the matrix Z*X;
*> if HOWMNY = 'S', the right eigenvectors of (S,P) 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 (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.
*
*> \ingroup tgevc
*
* =====================================================================
SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
$ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
$ VR( LDVR, * ), WORK( * )
* ..
*
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
$ LSA, LSB
INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
$ J, JE, JR
DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
$ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
$ SCALE, SMALL, TEMP, ULP, XMAX
COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
COMPLEX*16 ZLADIV
EXTERNAL LSAME, DLAMCH, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1
* ..
* .. Statement Function definitions ..
ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
IF( LSAME( HOWMNY, 'A' ) ) THEN
IHWMNY = 1
ILALL = .TRUE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
IHWMNY = 2
ILALL = .FALSE.
ILBACK = .FALSE.
ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
IHWMNY = 3
ILALL = .TRUE.
ILBACK = .TRUE.
ELSE
IHWMNY = -1
END IF
*
IF( LSAME( SIDE, 'R' ) ) THEN
ISIDE = 1
COMPL = .FALSE.
COMPR = .TRUE.
ELSE IF( LSAME( SIDE, 'L' ) ) THEN
ISIDE = 2
COMPL = .TRUE.
COMPR = .FALSE.
ELSE IF( LSAME( SIDE, 'B' ) ) THEN
ISIDE = 3
COMPL = .TRUE.
COMPR = .TRUE.
ELSE
ISIDE = -1
END IF
*
INFO = 0
IF( ISIDE.LT.0 ) THEN
INFO = -1
ELSE IF( IHWMNY.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGEVC', -INFO )
RETURN
END IF
*
* Count the number of eigenvectors
*
IF( .NOT.ILALL ) THEN
IM = 0
DO 10 J = 1, N
IF( SELECT( J ) )
$ IM = IM + 1
10 CONTINUE
ELSE
IM = N
END IF
*
* Check diagonal of B
*
ILBBAD = .FALSE.
DO 20 J = 1, N
IF( DIMAG( P( J, J ) ).NE.ZERO )
$ ILBBAD = .TRUE.
20 CONTINUE
*
IF( ILBBAD ) THEN
INFO = -7
ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
INFO = -10
ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
INFO = -12
ELSE IF( MM.LT.IM ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGEVC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = IM
IF( N.EQ.0 )
$ RETURN
*
* Machine Constants
*
SAFMIN = DLAMCH( 'Safe minimum' )
BIG = ONE / SAFMIN
ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
SMALL = SAFMIN*N / ULP
BIG = ONE / SMALL
BIGNUM = ONE / ( SAFMIN*N )
*
* Compute the 1-norm of each column of the strictly upper triangular
* part of A and B to check for possible overflow in the triangular
* solver.
*
ANORM = ABS1( S( 1, 1 ) )
BNORM = ABS1( P( 1, 1 ) )
RWORK( 1 ) = ZERO
RWORK( N+1 ) = ZERO
DO 40 J = 2, N
RWORK( J ) = ZERO
RWORK( N+J ) = ZERO
DO 30 I = 1, J - 1
RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) )
RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) )
30 CONTINUE
ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) )
BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) )
40 CONTINUE
*
ASCALE = ONE / MAX( ANORM, SAFMIN )
BSCALE = ONE / MAX( BNORM, SAFMIN )
*
* Left eigenvectors
*
IF( COMPL ) THEN
IEIG = 0
*
* Main loop over eigenvalues
*
DO 140 JE = 1, N
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE
ILCOMP = SELECT( JE )
END IF
IF( ILCOMP ) THEN
IEIG = IEIG + 1
*
IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
DO 50 JR = 1, N
VL( JR, IEIG ) = CZERO
50 CONTINUE
VL( IEIG, IEIG ) = CONE
GO TO 140
END IF
*
* Non-singular eigenvalue:
* Compute coefficients a and b in
* H
* y ( a A - b B ) = 0
*
TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
$ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
ACOEFF = SBETA*ASCALE
BCOEFF = SALPHA*BSCALE
*
* Scale to avoid underflow
*
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
$ SMALL
*
SCALE = ONE
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
$ ABS1( BCOEFF ) ) ) )
IF( LSA ) THEN
ACOEFF = ASCALE*( SCALE*SBETA )
ELSE
ACOEFF = SCALE*ACOEFF
END IF
IF( LSB ) THEN
BCOEFF = BSCALE*( SCALE*SALPHA )
ELSE
BCOEFF = SCALE*BCOEFF
END IF
END IF
*
ACOEFA = ABS( ACOEFF )
BCOEFA = ABS1( BCOEFF )
XMAX = ONE
DO 60 JR = 1, N
WORK( JR ) = CZERO
60 CONTINUE
WORK( JE ) = CONE
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* H
* Triangular solve of (a A - b B) y = 0
*
* H
* (rowwise in (a A - b B) , or columnwise in a A - b B)
*
DO 100 J = JE + 1, N
*
* Compute
* j-1
* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
* k=je
* (Scale if necessary)
*
TEMP = ONE / XMAX
IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM*
$ TEMP ) THEN
DO 70 JR = JE, J - 1
WORK( JR ) = TEMP*WORK( JR )
70 CONTINUE
XMAX = ONE
END IF
SUMA = CZERO
SUMB = CZERO
*
DO 80 JR = JE, J - 1
SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR )
SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR )
80 CONTINUE
SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB
*
* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
*
* with scaling and perturbation of the denominator
*
D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
IF( ABS1( D ).LE.DMIN )
$ D = DCMPLX( DMIN )
*
IF( ABS1( D ).LT.ONE ) THEN
IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN
TEMP = ONE / ABS1( SUM )
DO 90 JR = JE, J - 1
WORK( JR ) = TEMP*WORK( JR )
90 CONTINUE
XMAX = TEMP*XMAX
SUM = TEMP*SUM
END IF
END IF
WORK( J ) = ZLADIV( -SUM, D )
XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
100 CONTINUE
*
* Back transform eigenvector if HOWMNY='B'.
*
IF( ILBACK ) THEN
CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ),
$ LDVL,
$ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 )
ISRC = 2
IBEG = 1
ELSE
ISRC = 1
IBEG = JE
END IF
*
* Copy and scale eigenvector into column of VL
*
XMAX = ZERO
DO 110 JR = IBEG, N
XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
110 CONTINUE
*
IF( XMAX.GT.SAFMIN ) THEN
TEMP = ONE / XMAX
DO 120 JR = IBEG, N
VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
120 CONTINUE
ELSE
IBEG = N + 1
END IF
*
DO 130 JR = 1, IBEG - 1
VL( JR, IEIG ) = CZERO
130 CONTINUE
*
END IF
140 CONTINUE
END IF
*
* Right eigenvectors
*
IF( COMPR ) THEN
IEIG = IM + 1
*
* Main loop over eigenvalues
*
DO 250 JE = N, 1, -1
IF( ILALL ) THEN
ILCOMP = .TRUE.
ELSE
ILCOMP = SELECT( JE )
END IF
IF( ILCOMP ) THEN
IEIG = IEIG - 1
*
IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
$ ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
*
* Singular matrix pencil -- return unit eigenvector
*
DO 150 JR = 1, N
VR( JR, IEIG ) = CZERO
150 CONTINUE
VR( IEIG, IEIG ) = CONE
GO TO 250
END IF
*
* Non-singular eigenvalue:
* Compute coefficients a and b in
*
* ( a A - b B ) x = 0
*
TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
$ ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
ACOEFF = SBETA*ASCALE
BCOEFF = SALPHA*BSCALE
*
* Scale to avoid underflow
*
LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
$ SMALL
*
SCALE = ONE
IF( LSA )
$ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
IF( LSB )
$ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
$ MIN( BNORM, BIG ) )
IF( LSA .OR. LSB ) THEN
SCALE = MIN( SCALE, ONE /
$ ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
$ ABS1( BCOEFF ) ) ) )
IF( LSA ) THEN
ACOEFF = ASCALE*( SCALE*SBETA )
ELSE
ACOEFF = SCALE*ACOEFF
END IF
IF( LSB ) THEN
BCOEFF = BSCALE*( SCALE*SALPHA )
ELSE
BCOEFF = SCALE*BCOEFF
END IF
END IF
*
ACOEFA = ABS( ACOEFF )
BCOEFA = ABS1( BCOEFF )
XMAX = ONE
DO 160 JR = 1, N
WORK( JR ) = CZERO
160 CONTINUE
WORK( JE ) = CONE
DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
*
* Triangular solve of (a A - b B) x = 0 (columnwise)
*
* WORK(1:j-1) contains sums w,
* WORK(j+1:JE) contains x
*
DO 170 JR = 1, JE - 1
WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE )
170 CONTINUE
WORK( JE ) = CONE
*
DO 210 J = JE - 1, 1, -1
*
* Form x(j) := - w(j) / d
* with scaling and perturbation of the denominator
*
D = ACOEFF*S( J, J ) - BCOEFF*P( J, J )
IF( ABS1( D ).LE.DMIN )
$ D = DCMPLX( DMIN )
*
IF( ABS1( D ).LT.ONE ) THEN
IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN
TEMP = ONE / ABS1( WORK( J ) )
DO 180 JR = 1, JE
WORK( JR ) = TEMP*WORK( JR )
180 CONTINUE
END IF
END IF
*
WORK( J ) = ZLADIV( -WORK( J ), D )
*
IF( J.GT.1 ) THEN
*
* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
*
IF( ABS1( WORK( J ) ).GT.ONE ) THEN
TEMP = ONE / ABS1( WORK( J ) )
IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE.
$ BIGNUM*TEMP ) THEN
DO 190 JR = 1, JE
WORK( JR ) = TEMP*WORK( JR )
190 CONTINUE
END IF
END IF
*
CA = ACOEFF*WORK( J )
CB = BCOEFF*WORK( J )
DO 200 JR = 1, J - 1
WORK( JR ) = WORK( JR ) + CA*S( JR, J ) -
$ CB*P( JR, J )
200 CONTINUE
END IF
210 CONTINUE
*
* Back transform eigenvector if HOWMNY='B'.
*
IF( ILBACK ) THEN
CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1,
$ CZERO, WORK( N+1 ), 1 )
ISRC = 2
IEND = N
ELSE
ISRC = 1
IEND = JE
END IF
*
* Copy and scale eigenvector into column of VR
*
XMAX = ZERO
DO 220 JR = 1, IEND
XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
220 CONTINUE
*
IF( XMAX.GT.SAFMIN ) THEN
TEMP = ONE / XMAX
DO 230 JR = 1, IEND
VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
230 CONTINUE
ELSE
IEND = 0
END IF
*
DO 240 JR = IEND + 1, N
VR( JR, IEIG ) = CZERO
240 CONTINUE
*
END IF
250 CONTINUE
END IF
*
RETURN
*
* End of ZTGEVC
*
END
*> \brief \b ZTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an unitary equivalence transformation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGEX2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgex2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgex2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgex2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
* LDZ, J1, INFO )
*
* .. Scalar Arguments ..
* LOGICAL WANTQ, WANTZ
* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)
*> in an upper triangular matrix pair (A, B) by an unitary equivalence
*> transformation.
*>
*> (A, B) must be in generalized Schur canonical form, that is, A and
*> B are both upper triangular.
*>
*> Optionally, the matrices Q and Z of generalized Schur vectors are
*> updated.
*>
*> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H
*> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTQ
*> \verbatim
*> WANTQ is LOGICAL
*> .TRUE. : update the left transformation matrix Q;
*> .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> .TRUE. : update the right transformation matrix Z;
*> .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimensions (LDA,N)
*> On entry, the matrix A in the pair (A, B).
*> On exit, the updated matrix A.
*> \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, dimensions (LDB,N)
*> On entry, the matrix B in the pair (A, B).
*> On exit, the updated matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
*> the updated matrix Q.
*> Not referenced if WANTQ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1;
*> If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,
*> the updated matrix Z.
*> Not referenced if WANTZ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1;
*> If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[in] J1
*> \verbatim
*> J1 is INTEGER
*> The index to the first block (A11, B11).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> =0: Successful exit.
*> =1: The transformed matrix pair (A, B) would be too far
*> from generalized Schur form; the problem is ill-
*> conditioned.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgex2
*
*> \par Further Details:
* =====================
*>
*> In the current code both weak and strong stability tests are
*> performed. The user can omit the strong stability test by changing
*> the internal logical parameter WANDS to .FALSE.. See ref. [2] for
*> details.
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*> M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*> \n
*> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*> Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*> Estimation: Theory, Algorithms and Software, Report UMINF-94.04,
*> Department of Computing Science, Umea University, S-901 87 Umea,
*> Sweden, 1994. Also as LAPACK Working Note 87. To appear in
*> Numerical Algorithms, 1996.
*>
* =====================================================================
SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, J1, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION TWENTY
PARAMETER ( TWENTY = 2.0D+1 )
INTEGER LDST
PARAMETER ( LDST = 2 )
LOGICAL WANDS
PARAMETER ( WANDS = .TRUE. )
* ..
* .. Local Scalars ..
LOGICAL STRONG, WEAK
INTEGER I, M
DOUBLE PRECISION CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SUM,
$ THRESHA, THRESHB
COMPLEX*16 CDUM, F, G, SQ, SZ
* ..
* .. Local Arrays ..
COMPLEX*16 S( LDST, LDST ), T( LDST, LDST ), WORK( 8 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLARTG, ZLASSQ, ZROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
M = LDST
WEAK = .FALSE.
STRONG = .FALSE.
*
* Make a local copy of selected block in (A, B)
*
CALL ZLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
CALL ZLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
*
* Compute the threshold for testing the acceptance of swapping.
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
SCALE = DBLE( CZERO )
SUM = DBLE( CONE )
CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
CALL ZLASSQ( M*M, WORK, 1, SCALE, SUM )
SA = SCALE*SQRT( SUM )
SCALE = DBLE( CZERO )
SUM = DBLE( CONE )
CALL ZLASSQ( M*M, WORK(M*M+1), 1, SCALE, SUM )
SB = SCALE*SQRT( SUM )
*
* THRES has been changed from
* THRESH = MAX( TEN*EPS*SA, SMLNUM )
* to
* THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
* on 04/01/10.
* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
* Jim Demmel and Guillaume Revy. See forum post 1783.
*
THRESHA = MAX( TWENTY*EPS*SA, SMLNUM )
THRESHB = MAX( TWENTY*EPS*SB, SMLNUM )
*
* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks
* using Givens rotations and perform the swap tentatively.
*
F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
SA = ABS( S( 2, 2 ) ) * ABS( T( 1, 1 ) )
SB = ABS( S( 1, 1 ) ) * ABS( T( 2, 2 ) )
CALL ZLARTG( G, F, CZ, SZ, CDUM )
SZ = -SZ
CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) )
CALL ZROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, DCONJG( SZ ) )
IF( SA.GE.SB ) THEN
CALL ZLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM )
ELSE
CALL ZLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM )
END IF
CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ )
CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ )
*
* Weak stability test: |S21| <= O(EPS F-norm((A)))
* and |T21| <= O(EPS F-norm((B)))
*
WEAK = ABS( S( 2, 1 ) ).LE.THRESHA .AND.
$ ABS( T( 2, 1 ) ).LE.THRESHB
IF( .NOT.WEAK )
$ GO TO 20
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
* and
* F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
CALL ZROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -DCONJG( SZ ) )
CALL ZROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ,
$ -DCONJG( SZ ) )
CALL ZROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ )
CALL ZROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ )
DO 10 I = 1, 2
WORK( I ) = WORK( I ) - A( J1+I-1, J1 )
WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 )
WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 )
WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 )
10 CONTINUE
SCALE = DBLE( CZERO )
SUM = DBLE( CONE )
CALL ZLASSQ( M*M, WORK, 1, SCALE, SUM )
SA = SCALE*SQRT( SUM )
SCALE = DBLE( CZERO )
SUM = DBLE( CONE )
CALL ZLASSQ( M*M, WORK(M*M+1), 1, SCALE, SUM )
SB = SCALE*SQRT( SUM )
STRONG = SA.LE.THRESHA .AND. SB.LE.THRESHB
IF( .NOT.STRONG )
$ GO TO 20
END IF
*
* If the swap is accepted ("weakly" and "strongly"), apply the
* equivalence transformations to the original matrix pair (A,B)
*
CALL ZROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ,
$ DCONJG( SZ ) )
CALL ZROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ,
$ DCONJG( SZ ) )
CALL ZROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ,
$ SQ )
CALL ZROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ,
$ SQ )
*
* Set N1 by N2 (2,1) blocks to 0
*
A( J1+1, J1 ) = CZERO
B( J1+1, J1 ) = CZERO
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTZ )
$ CALL ZROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ,
$ DCONJG( SZ ) )
IF( WANTQ )
$ CALL ZROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ,
$ DCONJG( SQ ) )
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
* Exit with INFO = 1 if swap was rejected.
*
20 CONTINUE
INFO = 1
RETURN
*
* End of ZTGEX2
*
END
*> \brief \b ZTGEXC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGEXC + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgexc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgexc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgexc.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
* LDZ, IFST, ILST, INFO )
*
* .. Scalar Arguments ..
* LOGICAL WANTQ, WANTZ
* INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGEXC reorders the generalized Schur decomposition of a complex
*> matrix pair (A,B), using an unitary equivalence transformation
*> (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with
*> row index IFST is moved to row ILST.
*>
*> (A, B) must be in generalized Schur canonical form, that is, A and
*> B are both upper triangular.
*>
*> Optionally, the matrices Q and Z of generalized Schur vectors are
*> updated.
*>
*> Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H
*> Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTQ
*> \verbatim
*> WANTQ is LOGICAL
*> .TRUE. : update the left transformation matrix Q;
*> .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> .TRUE. : update the right transformation matrix Z;
*> .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the upper triangular matrix A in the pair (A, B).
*> On exit, the updated matrix A.
*> \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,N)
*> On entry, the upper triangular matrix B in the pair (A, B).
*> On exit, the updated matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if WANTQ = .TRUE., the unitary matrix Q.
*> On exit, the updated matrix Q.
*> If WANTQ = .FALSE., Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1;
*> If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> On entry, if WANTZ = .TRUE., the unitary matrix Z.
*> On exit, the updated matrix Z.
*> If WANTZ = .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1;
*> If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[in] IFST
*> \verbatim
*> IFST is INTEGER
*> \endverbatim
*>
*> \param[in,out] ILST
*> \verbatim
*> ILST is INTEGER
*> Specify the reordering of the diagonal blocks of (A, B).
*> The block with row index IFST is moved to row ILST, by a
*> sequence of swapping between adjacent blocks.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> =0: Successful exit.
*> <0: if INFO = -i, the i-th argument had an illegal value.
*> =1: The transformed matrix pair (A, B) would be too far
*> from generalized Schur form; the problem is ill-
*> conditioned. (A, B) may have been partially reordered,
*> and ILST points to the first row of the current
*> position of the block being moved.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgexc
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*> M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*> \n
*> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*> Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*> Estimation: Theory, Algorithms and Software, Report
*> UMINF - 94.04, Department of Computing Science, Umea University,
*> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
*> To appear in Numerical Algorithms, 1996.
*> \n
*> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
*> for Solving the Generalized Sylvester Equation and Estimating the
*> Separation between Regular Matrix Pairs, Report UMINF - 93.23,
*> Department of Computing Science, Umea University, S-901 87 Umea,
*> Sweden, December 1993, Revised April 1994, Also as LAPACK working
*> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
*> 1996.
*>
* =====================================================================
SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, IFST, ILST, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER HERE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTGEX2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input arguments.
INFO = 0
IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -11
ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
INFO = -12
ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGEXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
IF( IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
HERE = IFST
*
10 CONTINUE
*
* Swap with next one below
*
CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ,
$ HERE, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE + 1
IF( HERE.LT.ILST )
$ GO TO 10
HERE = HERE - 1
ELSE
HERE = IFST - 1
*
20 CONTINUE
*
* Swap with next one above
*
CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ,
$ HERE, INFO )
IF( INFO.NE.0 ) THEN
ILST = HERE
RETURN
END IF
HERE = HERE - 1
IF( HERE.GE.ILST )
$ GO TO 20
HERE = HERE + 1
END IF
ILST = HERE
RETURN
*
* End of ZTGEXC
*
END
*> \brief \b ZTGSEN
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsen.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsen.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
* ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
* WORK, LWORK, IWORK, LIWORK, INFO )
*
* .. Scalar Arguments ..
* LOGICAL WANTQ, WANTZ
* INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
* $ M, N
* DOUBLE PRECISION PL, PR
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* INTEGER IWORK( * )
* DOUBLE PRECISION DIF( * )
* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
* $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGSEN reorders the generalized Schur decomposition of a complex
*> matrix pair (A, B) (in terms of an unitary equivalence trans-
*> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues
*> appears in the leading diagonal blocks of the pair (A,B). The leading
*> columns of Q and Z form unitary bases of the corresponding left and
*> right eigenspaces (deflating subspaces). (A, B) must be in
*> generalized Schur canonical form, that is, A and B are both upper
*> triangular.
*>
*> ZTGSEN also computes the generalized eigenvalues
*>
*> w(j)= ALPHA(j) / BETA(j)
*>
*> of the reordered matrix pair (A, B).
*>
*> Optionally, the routine computes estimates of reciprocal condition
*> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
*> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
*> between the matrix pairs (A11, B11) and (A22,B22) that correspond to
*> the selected cluster and the eigenvalues outside the cluster, resp.,
*> and norms of "projections" onto left and right eigenspaces w.r.t.
*> the selected cluster in the (1,1)-block.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> Specifies whether condition numbers are required for the
*> cluster of eigenvalues (PL and PR) or the deflating subspaces
*> (Difu and Difl):
*> =0: Only reorder w.r.t. SELECT. No extras.
*> =1: Reciprocal of norms of "projections" onto left and right
*> eigenspaces w.r.t. the selected cluster (PL and PR).
*> =2: Upper bounds on Difu and Difl. F-norm-based estimate
*> (DIF(1:2)).
*> =3: Estimate of Difu and Difl. 1-norm-based estimate
*> (DIF(1:2)).
*> About 5 times as expensive as IJOB = 2.
*> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
*> version to get it all.
*> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
*> \endverbatim
*>
*> \param[in] WANTQ
*> \verbatim
*> WANTQ is LOGICAL
*> .TRUE. : update the left transformation matrix Q;
*> .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> .TRUE. : update the right transformation matrix Z;
*> .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> SELECT specifies the eigenvalues in the selected cluster. To
*> select an eigenvalue w(j), SELECT(j) must be set to
*> .TRUE..
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension(LDA,N)
*> On entry, the upper triangular matrix A, in generalized
*> Schur canonical form.
*> On exit, A is overwritten by the reordered matrix A.
*> \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,N)
*> On entry, the upper triangular matrix B, in generalized
*> Schur canonical form.
*> On exit, B is overwritten by the reordered matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*> BETA is COMPLEX*16 array, dimension (N)
*>
*> The diagonal elements of A and B, respectively,
*> when the pair (A,B) has been reduced to generalized Schur
*> form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
*> eigenvalues.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
*> On exit, Q has been postmultiplied by the left unitary
*> transformation matrix which reorder (A, B); The leading M
*> columns of Q form orthonormal bases for the specified pair of
*> left eigenspaces (deflating subspaces).
*> If WANTQ = .FALSE., Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1.
*> If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
*> On exit, Z has been postmultiplied by the left unitary
*> transformation matrix which reorder (A, B); The leading M
*> columns of Z form orthonormal bases for the specified pair of
*> left eigenspaces (deflating subspaces).
*> If WANTZ = .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1.
*> If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The dimension of the specified pair of left and right
*> eigenspaces, (deflating subspaces) 0 <= M <= N.
*> \endverbatim
*>
*> \param[out] PL
*> \verbatim
*> PL is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] PR
*> \verbatim
*> PR is DOUBLE PRECISION
*>
*> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
*> reciprocal of the norm of "projections" onto left and right
*> eigenspace with respect to the selected cluster.
*> 0 < PL, PR <= 1.
*> If M = 0 or M = N, PL = PR = 1.
*> If IJOB = 0, 2 or 3 PL, PR are not referenced.
*> \endverbatim
*>
*> \param[out] DIF
*> \verbatim
*> DIF is DOUBLE PRECISION array, dimension (2).
*> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
*> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
*> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
*> estimates of Difu and Difl, computed using reversed
*> communication with ZLACN2.
*> If M = 0 or N, DIF(1:2) = F-norm([A, B]).
*> If IJOB = 0 or 1, DIF is not referenced.
*> \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 IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
*> If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*> LIWORK is INTEGER
*> The dimension of the array IWORK. LIWORK >= 1.
*> If IJOB = 1, 2 or 4, LIWORK >= N+2;
*> If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
*>
*> If LIWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal size of the IWORK array,
*> returns this value as the first entry of the IWORK array, and
*> no error message related to LIWORK 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.
*> =1: Reordering of (A, B) failed because the transformed
*> matrix pair (A, B) would be too far from generalized
*> Schur form; the problem is very ill-conditioned.
*> (A, B) may have been partially reordered.
*> If requested, 0 is returned in DIF(*), PL and PR.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgsen
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> ZTGSEN first collects the selected eigenvalues by computing unitary
*> U and W that move them to the top left corner of (A, B). In other
*> words, the selected eigenvalues are the eigenvalues of (A11, B11) in
*>
*> U**H*(A, B)*W = (A11 A12) (B11 B12) n1
*> ( 0 A22),( 0 B22) n2
*> n1 n2 n1 n2
*>
*> where N = n1+n2 and U**H means the conjugate transpose of U. The first
*> n1 columns of U and W span the specified pair of left and right
*> eigenspaces (deflating subspaces) of (A, B).
*>
*> If (A, B) has been obtained from the generalized real Schur
*> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the
*> reordered generalized Schur form of (C, D) is given by
*>
*> (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
*>
*> and the first n1 columns of Q*U and Z*W span the corresponding
*> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
*>
*> Note that if the selected eigenvalue is sufficiently ill-conditioned,
*> then its value may differ significantly from its value before
*> reordering.
*>
*> The reciprocal condition numbers of the left and right eigenspaces
*> spanned by the first n1 columns of U and W (or Q*U and Z*W) may
*> be returned in DIF(1:2), corresponding to Difu and Difl, resp.
*>
*> The Difu and Difl are defined as:
*>
*> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
*> and
*> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
*>
*> where sigma-min(Zu) is the smallest singular value of the
*> (2*n1*n2)-by-(2*n1*n2) matrix
*>
*> Zu = [ kron(In2, A11) -kron(A22**H, In1) ]
*> [ kron(In2, B11) -kron(B22**H, In1) ].
*>
*> Here, Inx is the identity matrix of size nx and A22**H is the
*> conjugate transpose of A22. kron(X, Y) is the Kronecker product between
*> the matrices X and Y.
*>
*> When DIF(2) is small, small changes in (A, B) can cause large changes
*> in the deflating subspace. An approximate (asymptotic) bound on the
*> maximum angular error in the computed deflating subspaces is
*>
*> EPS * norm((A, B)) / DIF(2),
*>
*> where EPS is the machine precision.
*>
*> The reciprocal norm of the projectors on the left and right
*> eigenspaces associated with (A11, B11) may be returned in PL and PR.
*> They are computed as follows. First we compute L and R so that
*> P*(A, B)*Q is block diagonal, where
*>
*> P = ( I -L ) n1 Q = ( I R ) n1
*> ( 0 I ) n2 and ( 0 I ) n2
*> n1 n2 n1 n2
*>
*> and (L, R) is the solution to the generalized Sylvester equation
*>
*> A11*R - L*A22 = -A12
*> B11*R - L*B22 = -B12
*>
*> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
*> An approximate (asymptotic) bound on the average absolute error of
*> the selected eigenvalues is
*>
*> EPS * norm((A, B)) / PL.
*>
*> There are also global error bounds which valid for perturbations up
*> to a certain restriction: A lower bound (x) on the smallest
*> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
*> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
*> (i.e. (A + E, B + F), is
*>
*> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
*>
*> An approximate bound on x can be computed from DIF(1:2), PL and PR.
*>
*> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
*> (L', R') and unperturbed (L, R) left and right deflating subspaces
*> associated with the selected cluster in the (1,1)-blocks can be
*> bounded as
*>
*> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
*> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
*>
*> See LAPACK User's Guide section 4.11 or the following references
*> for more information.
*>
*> Note that if the default method for computing the Frobenius-norm-
*> based estimate DIF is not wanted (see ZLATDF), then the parameter
*> IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
*> (IJOB = 2 will be used)). See ZTGSYL for more details.
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*> M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*> \n
*> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*> Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*> Estimation: Theory, Algorithms and Software, Report
*> UMINF - 94.04, Department of Computing Science, Umea University,
*> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
*> To appear in Numerical Algorithms, 1996.
*> \n
*> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
*> for Solving the Generalized Sylvester Equation and Estimating the
*> Separation between Regular Matrix Pairs, Report UMINF - 93.23,
*> Department of Computing Science, Umea University, S-901 87 Umea,
*> Sweden, December 1993, Revised April 1994, Also as LAPACK working
*> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
*> 1996.
*>
* =====================================================================
SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B,
$ LDB,
$ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
$ WORK, LWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
$ M, N
DOUBLE PRECISION PL, PR
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
INTEGER IWORK( * )
DOUBLE PRECISION DIF( * )
COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
$ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER IDIFJB
PARAMETER ( IDIFJB = 3 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
$ N1, N2
DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN
COMPLEX*16 TEMP1, TEMP2
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL,
$ ZTGEXC,
$ ZTGSYL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DCMPLX, DCONJG, MAX, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
INFO = -1
ELSE IF( N.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
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -13
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGSEN', -INFO )
RETURN
END IF
*
IERR = 0
*
WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
WANTD = WANTD1 .OR. WANTD2
*
* Set M to the dimension of the specified pair of deflating
* subspaces.
*
M = 0
IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN
DO 10 K = 1, N
ALPHA( K ) = A( K, K )
BETA( K ) = B( K, K )
IF( K.LT.N ) THEN
IF( SELECT( K ) )
$ M = M + 1
ELSE
IF( SELECT( N ) )
$ M = M + 1
END IF
10 CONTINUE
END IF
*
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
LWMIN = MAX( 1, 2*M*( N-M ) )
LIWMIN = MAX( 1, N+2 )
ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
LWMIN = MAX( 1, 4*M*( N-M ) )
LIWMIN = MAX( 1, 2*M*( N-M ), N+2 )
ELSE
LWMIN = 1
LIWMIN = 1
END IF
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -21
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -23
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTP ) THEN
PL = ONE
PR = ONE
END IF
IF( WANTD ) THEN
DSCALE = ZERO
DSUM = ONE
DO 20 I = 1, N
CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
20 CONTINUE
DIF( 1 ) = DSCALE*SQRT( DSUM )
DIF( 2 ) = DIF( 1 )
END IF
GO TO 70
END IF
*
* Get machine constant
*
SAFMIN = DLAMCH( 'S' )
*
* Collect the selected blocks at the top-left corner of (A, B).
*
KS = 0
DO 30 K = 1, N
SWAP = SELECT( K )
IF( SWAP ) THEN
KS = KS + 1
*
* Swap the K-th block to position KS. Compute unitary Q
* and Z that will swap adjacent diagonal blocks in (A, B).
*
IF( K.NE.KS )
$ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
$ Z,
$ LDZ, K, KS, IERR )
*
IF( IERR.GT.0 ) THEN
*
* Swap is rejected: exit.
*
INFO = 1
IF( WANTP ) THEN
PL = ZERO
PR = ZERO
END IF
IF( WANTD ) THEN
DIF( 1 ) = ZERO
DIF( 2 ) = ZERO
END IF
GO TO 70
END IF
END IF
30 CONTINUE
IF( WANTP ) THEN
*
* Solve generalized Sylvester equation for R and L:
* A11 * R - L * A22 = A12
* B11 * R - L * B22 = B12
*
N1 = M
N2 = N - M
I = N1 + 1
CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB,
$ WORK( N1*N2+1 ),
$ N1 )
IJB = 0
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
$ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Estimate the reciprocal of norms of "projections" onto
* left and right eigenspaces
*
RDSCAL = ZERO
DSUM = ONE
CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
PL = RDSCAL*SQRT( DSUM )
IF( PL.EQ.ZERO ) THEN
PL = ONE
ELSE
PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
END IF
RDSCAL = ZERO
DSUM = ONE
CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
PR = RDSCAL*SQRT( DSUM )
IF( PR.EQ.ZERO ) THEN
PR = ONE
ELSE
PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
END IF
END IF
IF( WANTD ) THEN
*
* Compute estimates Difu and Difl.
*
IF( WANTD1 ) THEN
N1 = M
N2 = N - M
I = N1 + 1
IJB = IDIFJB
*
* Frobenius norm-based Difu estimate.
*
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
$ WORK,
$ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
$ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
*
* Frobenius norm-based Difl estimate.
*
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
$ WORK,
$ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
$ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
$ LWORK-2*N1*N2, IWORK, IERR )
ELSE
*
* Compute 1-norm-based estimates of Difu and Difl using
* reversed communication with ZLACN2. In each step a
* generalized Sylvester equation or a transposed variant
* is solved.
*
KASE = 0
N1 = M
N2 = N - M
I = N1 + 1
IJB = 0
MN2 = 2*N1*N2
*
* 1-norm-based estimate of Difu.
*
40 CONTINUE
CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE,
$ ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation
*
CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ),
$ LDA,
$ WORK, N1, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 40
END IF
DIF( 1 ) = DSCALE / DIF( 1 )
*
* 1-norm-based estimate of Difl.
*
50 CONTINUE
CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE,
$ ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve generalized Sylvester equation
*
CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B( I, I ), LDB, B, LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
ELSE
*
* Solve the transposed variant.
*
CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A,
$ LDA,
$ WORK, N2, B, LDB, B( I, I ), LDB,
$ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
$ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
$ IERR )
END IF
GO TO 50
END IF
DIF( 2 ) = DSCALE / DIF( 2 )
END IF
END IF
*
* If B(K,K) is complex, make it real and positive (normalization
* of the generalized Schur form) and Store the generalized
* eigenvalues of reordered pair (A, B)
*
DO 60 K = 1, N
DSCALE = ABS( B( K, K ) )
IF( DSCALE.GT.SAFMIN ) THEN
TEMP1 = DCONJG( B( K, K ) / DSCALE )
TEMP2 = B( K, K ) / DSCALE
B( K, K ) = DSCALE
CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB )
CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA )
IF( WANTQ )
$ CALL ZSCAL( N, TEMP2, Q( 1, K ), 1 )
ELSE
B( K, K ) = DCMPLX( ZERO, ZERO )
END IF
*
ALPHA( K ) = A( K, K )
BETA( K ) = B( K, K )
*
60 CONTINUE
*
70 CONTINUE
*
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of ZTGSEN
*
END
*> \brief \b ZTGSY2 solves the generalized Sylvester equation (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGSY2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsy2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsy2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsy2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
* DOUBLE PRECISION RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
* $ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGSY2 solves the generalized Sylvester equation
*>
*> A * R - L * B = scale * C (1)
*> D * R - L * E = scale * F
*>
*> using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
*> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
*> N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
*> (i.e., (A,D) and (B,E) in generalized Schur form).
*>
*> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
*> scaling factor chosen to avoid overflow.
*>
*> In matrix notation solving equation (1) corresponds to solve
*> Zx = scale * b, where Z is defined as
*>
*> Z = [ kron(In, A) -kron(B**H, Im) ] (2)
*> [ kron(In, D) -kron(E**H, Im) ],
*>
*> Ik is the identity matrix of size k and X**H is the conjugate transpose of X.
*> kron(X, Y) is the Kronecker product between the matrices X and Y.
*>
*> If TRANS = 'C', y in the conjugate transposed system Z**H*y = scale*b
*> is solved for, which is equivalent to solve for R and L in
*>
*> A**H * R + D**H * L = scale * C (3)
*> R * B**H + L * E**H = scale * -F
*>
*> This case is used to compute an estimate of Dif[(A, D), (B, E)] =
*> = sigma_min(Z) using reverse communication with ZLACON.
*>
*> ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL
*> of an upper bound on the separation between to matrix pairs. Then
*> the input (A, D), (B, E) are sub-pencils of two matrix pairs in
*> ZTGSYL.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': solve the generalized Sylvester equation (1).
*> = 'T': solve the 'transposed' system (3).
*> \endverbatim
*>
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> Specifies what kind of functionality to be performed.
*> =0: solve (1) only.
*> =1: A contribution from this subsystem to a Frobenius
*> norm-based estimate of the separation between two matrix
*> pairs is computed. (look ahead strategy is used).
*> =2: A contribution from this subsystem to a Frobenius
*> norm-based estimate of the separation between two matrix
*> pairs is computed. (DGECON on sub-systems is used.)
*> Not referenced if TRANS = 'T'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the order of A and D, and the row
*> dimension of C, F, R and L.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of B and E, and the column
*> dimension of C, F, R and L.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, M)
*> On entry, A contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the matrix A. LDA >= max(1, M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB, N)
*> On entry, B contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the matrix B. LDB >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> On entry, C contains the right-hand-side of the first matrix
*> equation in (1).
*> On exit, if IJOB = 0, C has been overwritten by the solution
*> R.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the matrix C. LDC >= max(1, M).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (LDD, M)
*> On entry, D contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDD
*> \verbatim
*> LDD is INTEGER
*> The leading dimension of the matrix D. LDD >= max(1, M).
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is COMPLEX*16 array, dimension (LDE, N)
*> On entry, E contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*> LDE is INTEGER
*> The leading dimension of the matrix E. LDE >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] F
*> \verbatim
*> F is COMPLEX*16 array, dimension (LDF, N)
*> On entry, F contains the right-hand-side of the second matrix
*> equation in (1).
*> On exit, if IJOB = 0, F has been overwritten by the solution
*> L.
*> \endverbatim
*>
*> \param[in] LDF
*> \verbatim
*> LDF is INTEGER
*> The leading dimension of the matrix F. LDF >= max(1, M).
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
*> R and L (C and F on entry) will hold the solutions to a
*> slightly perturbed system but the input matrices A, B, D and
*> E have not been changed. If SCALE = 0, R and L will hold the
*> solutions to the homogeneous system with C = F = 0.
*> Normally, SCALE = 1.
*> \endverbatim
*>
*> \param[in,out] RDSUM
*> \verbatim
*> RDSUM is DOUBLE PRECISION
*> On entry, the sum of squares of computed contributions to
*> the Dif-estimate under computation by ZTGSYL, where the
*> scaling factor RDSCAL (see below) has been factored out.
*> On exit, the corresponding sum of squares updated with the
*> contributions from the current sub-system.
*> If TRANS = 'T' RDSUM is not touched.
*> NOTE: RDSUM only makes sense when ZTGSY2 is called by
*> ZTGSYL.
*> \endverbatim
*>
*> \param[in,out] RDSCAL
*> \verbatim
*> RDSCAL is DOUBLE PRECISION
*> On entry, scaling factor used to prevent overflow in RDSUM.
*> On exit, RDSCAL is updated w.r.t. the current contributions
*> in RDSUM.
*> If TRANS = 'T', RDSCAL is not touched.
*> NOTE: RDSCAL only makes sense when ZTGSY2 is called by
*> ZTGSYL.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> On exit, if INFO is set to
*> =0: Successful exit
*> <0: If INFO = -i, input argument number i is illegal.
*> >0: The matrix pairs (A, D) and (B, E) have common or very
*> close eigenvalues.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgsy2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC,
$ D,
$ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
$ INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
DOUBLE PRECISION RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
INTEGER LDZ
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, LDZ = 2 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IERR, J, K
DOUBLE PRECISION SCALOC
COMPLEX*16 ALPHA
* ..
* .. Local Arrays ..
INTEGER IPIV( LDZ ), JPIV( LDZ )
COMPLEX*16 RHS( LDZ ), Z( LDZ, LDZ )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZGESC2, ZGETC2, ZLATDF,
$ ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCMPLX, DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
IERR = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGSY2', -INFO )
RETURN
END IF
*
IF( NOTRAN ) THEN
*
* Solve (I, J) - system
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = M, M - 1, ..., 1; J = 1, 2, ..., N
*
SCALE = ONE
SCALOC = ONE
DO 30 J = 1, N
DO 20 I = M, 1, -1
*
* Build 2 by 2 system
*
Z( 1, 1 ) = A( I, I )
Z( 2, 1 ) = D( I, I )
Z( 1, 2 ) = -B( J, J )
Z( 2, 2 ) = -E( J, J )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( I, J )
RHS( 2 ) = F( I, J )
*
* Solve Z * x = RHS
*
CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 10 K = 1, N
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ C( 1, K ), 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ F( 1, K ), 1 )
10 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL ZLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL,
$ IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( I, J ) = RHS( 1 )
F( I, J ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining equation.
*
IF( I.GT.1 ) THEN
ALPHA = -RHS( 1 )
CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ),
$ 1 )
CALL ZAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ),
$ 1 )
END IF
IF( J.LT.N ) THEN
CALL ZAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB,
$ C( I, J+1 ), LDC )
CALL ZAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE,
$ F( I, J+1 ), LDF )
END IF
*
20 CONTINUE
30 CONTINUE
ELSE
*
* Solve transposed (I, J) - system:
* A(I, I)**H * R(I, J) + D(I, I)**H * L(J, J) = C(I, J)
* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1, 2, ..., M, J = N, N - 1, ..., 1
*
SCALE = ONE
SCALOC = ONE
DO 80 I = 1, M
DO 70 J = N, 1, -1
*
* Build 2 by 2 system Z**H
*
Z( 1, 1 ) = DCONJG( A( I, I ) )
Z( 2, 1 ) = -DCONJG( B( J, J ) )
Z( 1, 2 ) = DCONJG( D( I, I ) )
Z( 2, 2 ) = -DCONJG( E( J, J ) )
*
*
* Set up right hand side(s)
*
RHS( 1 ) = C( I, J )
RHS( 2 ) = F( I, J )
*
* Solve Z**H * x = RHS
*
CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 40 K = 1, N
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1,
$ K ),
$ 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1,
$ K ),
$ 1 )
40 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( I, J ) = RHS( 1 )
F( I, J ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining equation.
*
DO 50 K = 1, J - 1
F( I, K ) = F( I, K ) + RHS( 1 )*DCONJG( B( K, J ) ) +
$ RHS( 2 )*DCONJG( E( K, J ) )
50 CONTINUE
DO 60 K = I + 1, M
C( K, J ) = C( K, J ) - DCONJG( A( I, K ) )*RHS( 1 ) -
$ DCONJG( D( I, K ) )*RHS( 2 )
60 CONTINUE
*
70 CONTINUE
80 CONTINUE
END IF
RETURN
*
* End of ZTGSY2
*
END
*> \brief \b ZTGSYL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTGSYL + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsyl.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsyl.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsyl.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
* LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
* IWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
* $ LWORK, M, N
* DOUBLE PRECISION DIF, SCALE
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
* $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTGSYL solves the generalized Sylvester equation:
*>
*> A * R - L * B = scale * C (1)
*> D * R - L * E = scale * F
*>
*> where R and L are unknown m-by-n matrices, (A, D), (B, E) and
*> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
*> respectively, with complex entries. A, B, D and E are upper
*> triangular (i.e., (A,D) and (B,E) in generalized Schur form).
*>
*> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
*> is an output scaling factor chosen to avoid overflow.
*>
*> In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
*> is defined as
*>
*> Z = [ kron(In, A) -kron(B**H, Im) ] (2)
*> [ kron(In, D) -kron(E**H, Im) ],
*>
*> Here Ix is the identity matrix of size x and X**H is the conjugate
*> transpose of X. Kron(X, Y) is the Kronecker product between the
*> matrices X and Y.
*>
*> If TRANS = 'C', y in the conjugate transposed system Z**H *y = scale*b
*> is solved for, which is equivalent to solve for R and L in
*>
*> A**H * R + D**H * L = scale * C (3)
*> R * B**H + L * E**H = scale * -F
*>
*> This case (TRANS = 'C') is used to compute an one-norm-based estimate
*> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
*> and (B,E), using ZLACON.
*>
*> If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of
*> Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
*> reciprocal of the smallest singular value of Z.
*>
*> This is a level-3 BLAS algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': solve the generalized sylvester equation (1).
*> = 'C': solve the "conjugate transposed" system (3).
*> \endverbatim
*>
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> Specifies what kind of functionality to be performed.
*> =0: solve (1) only.
*> =1: The functionality of 0 and 3.
*> =2: The functionality of 0 and 4.
*> =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
*> (look ahead strategy is used).
*> =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
*> (ZGECON on sub-systems is used).
*> Not referenced if TRANS = 'C'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The order of the matrices A and D, and the row dimension of
*> the matrices C, F, R and L.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices B and E, and the column dimension
*> of the matrices C, F, R and L.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, M)
*> The upper triangular 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 COMPLEX*16 array, dimension (LDB, N)
*> The upper triangular matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> On entry, C contains the right-hand-side of the first matrix
*> equation in (1) or (3).
*> On exit, if IJOB = 0, 1 or 2, C has been overwritten by
*> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
*> the solution achieved during the computation of the
*> Dif-estimate.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1, M).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is COMPLEX*16 array, dimension (LDD, M)
*> The upper triangular matrix D.
*> \endverbatim
*>
*> \param[in] LDD
*> \verbatim
*> LDD is INTEGER
*> The leading dimension of the array D. LDD >= max(1, M).
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is COMPLEX*16 array, dimension (LDE, N)
*> The upper triangular matrix E.
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*> LDE is INTEGER
*> The leading dimension of the array E. LDE >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] F
*> \verbatim
*> F is COMPLEX*16 array, dimension (LDF, N)
*> On entry, F contains the right-hand-side of the second matrix
*> equation in (1) or (3).
*> On exit, if IJOB = 0, 1 or 2, F has been overwritten by
*> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
*> the solution achieved during the computation of the
*> Dif-estimate.
*> \endverbatim
*>
*> \param[in] LDF
*> \verbatim
*> LDF is INTEGER
*> The leading dimension of the array F. LDF >= max(1, M).
*> \endverbatim
*>
*> \param[out] DIF
*> \verbatim
*> DIF is DOUBLE PRECISION
*> On exit DIF is the reciprocal of a lower bound of the
*> reciprocal of the Dif-function, i.e. DIF is an upper bound of
*> Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
*> IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On exit SCALE is the scaling factor in (1) or (3).
*> If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
*> to a slightly perturbed system but the input matrices A, B,
*> D and E have not been changed. If SCALE = 0, R and L will
*> hold the solutions to the homogeneous system with C = F = 0.
*> \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 IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (M+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: (A, D) and (B, E) have common or very close
*> eigenvalues.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgsyl
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
*> for Solving the Generalized Sylvester Equation and Estimating the
*> Separation between Regular Matrix Pairs, Report UMINF - 93.23,
*> Department of Computing Science, Umea University, S-901 87 Umea,
*> Sweden, December 1993, Revised April 1994, Also as LAPACK Working
*> Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
*> No 1, 1996.
*> \n
*> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
*> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
*> Appl., 15(4):1045-1060, 1994.
*> \n
*> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
*> Condition Estimators for Solving the Generalized Sylvester
*> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
*> July 1989, pp 745-751.
*>
* =====================================================================
SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC,
$ D,
$ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
$ IWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
$ LWORK, M, N
DOUBLE PRECISION DIF, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * ),
$ WORK( * )
* ..
*
* =====================================================================
* Replaced various illegal calls to CCOPY by calls to CLASET.
* Sven Hammarling, 1/5/02.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, NOTRAN
INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
$ LINFO, LWMIN, MB, NB, P, PQ, Q
DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZLACPY, ZLASET, ZSCAL,
$ ZTGSY2
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( NOTRAN ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
LWMIN = MAX( 1, 2*M*N )
ELSE
LWMIN = 1
END IF
ELSE
LWMIN = 1
END IF
WORK( 1 ) = LWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTGSYL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
SCALE = 1
IF( NOTRAN ) THEN
IF( IJOB.NE.0 ) THEN
DIF = 0
END IF
END IF
RETURN
END IF
*
* Determine optimal block sizes MB and NB
*
MB = ILAENV( 2, 'ZTGSYL', TRANS, M, N, -1, -1 )
NB = ILAENV( 5, 'ZTGSYL', TRANS, M, N, -1, -1 )
*
ISOLVE = 1
IFUNC = 0
IF( NOTRAN ) THEN
IF( IJOB.GE.3 ) THEN
IFUNC = IJOB - 2
CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
ISOLVE = 2
END IF
END IF
*
IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
$ THEN
*
* Use unblocked Level 2 solver
*
DO 30 IROUND = 1, ISOLVE
*
SCALE = ONE
DSCALE = ZERO
DSUM = ONE
PQ = M*N
CALL ZTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC,
$ D,
$ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
$ INFO )
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
30 CONTINUE
*
RETURN
*
END IF
*
* Determine block structure of A
*
P = 0
I = 1
40 CONTINUE
IF( I.GT.M )
$ GO TO 50
P = P + 1
IWORK( P ) = I
I = I + MB
IF( I.GE.M )
$ GO TO 50
GO TO 40
50 CONTINUE
IWORK( P+1 ) = M + 1
IF( IWORK( P ).EQ.IWORK( P+1 ) )
$ P = P - 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
60 CONTINUE
IF( J.GT.N )
$ GO TO 70
*
Q = Q + 1
IWORK( Q ) = J
J = J + NB
IF( J.GE.N )
$ GO TO 70
GO TO 60
*
70 CONTINUE
IWORK( Q+1 ) = N + 1
IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
$ Q = Q - 1
*
IF( NOTRAN ) THEN
DO 150 IROUND = 1, ISOLVE
*
* Solve (I, J) - subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
*
PQ = 0
SCALE = ONE
DSCALE = ZERO
DSUM = ONE
DO 130 J = P + 2, Q
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 120 I = P, 1, -1
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ),
$ LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
PQ = PQ + MB*NB
IF( SCALOC.NE.ONE ) THEN
DO 80 K = 1, JS - 1
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ C( 1, K ), 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ F( 1, K ), 1 )
80 CONTINUE
DO 90 K = JS, JE
CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
$ C( 1, K ), 1 )
CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
$ F( 1, K ), 1 )
90 CONTINUE
DO 100 K = JS, JE
CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
$ C( IE+1, K ), 1 )
CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
$ F( IE+1, K ), 1 )
100 CONTINUE
DO 110 K = JE + 1, N
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ C( 1, K ), 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
$ F( 1, K ), 1 )
110 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I,J) and L(I,J) into remaining equation.
*
IF( I.GT.1 ) THEN
CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
$ DCMPLX( -ONE, ZERO ), A( 1, IS ), LDA,
$ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
$ C( 1, JS ), LDC )
CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
$ DCMPLX( -ONE, ZERO ), D( 1, IS ), LDD,
$ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
$ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
$ B( JS, JE+1 ), LDB,
$ DCMPLX( ONE, ZERO ), C( IS, JE+1 ),
$ LDC )
CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
$ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
$ E( JS, JE+1 ), LDE,
$ DCMPLX( ONE, ZERO ), F( IS, JE+1 ),
$ LDF )
END IF
120 CONTINUE
130 CONTINUE
IF( DSCALE.NE.ZERO ) THEN
IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
ELSE
DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
END IF
END IF
IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
IF( NOTRAN ) THEN
IFUNC = IJOB
END IF
SCALE2 = SCALE
CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
SCALE = SCALE2
END IF
150 CONTINUE
ELSE
*
* Solve transposed (I, J)-subsystem
* A(I, I)**H * R(I, J) + D(I, I)**H * L(I, J) = C(I, J)
* R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1,2,..., P; J = Q, Q-1,..., 1
*
SCALE = ONE
DO 210 I = 1, P
IS = IWORK( I )
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
DO 200 J = Q, P + 2, -1
JS = IWORK( J )
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
$ B( JS, JS ), LDB, C( IS, JS ), LDC,
$ D( IS, IS ), LDD, E( JS, JS ), LDE,
$ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
$ LINFO )
IF( LINFO.GT.0 )
$ INFO = LINFO
IF( SCALOC.NE.ONE ) THEN
DO 160 K = 1, JS - 1
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1,
$ K ),
$ 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1,
$ K ),
$ 1 )
160 CONTINUE
DO 170 K = JS, JE
CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
$ C( 1, K ), 1 )
CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
$ F( 1, K ), 1 )
170 CONTINUE
DO 180 K = JS, JE
CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
$ C( IE+1, K ), 1 )
CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
$ F( IE+1, K ), 1 )
180 CONTINUE
DO 190 K = JE + 1, N
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1,
$ K ),
$ 1 )
CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1,
$ K ),
$ 1 )
190 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Substitute R(I,J) and L(I,J) into remaining equation.
*
IF( J.GT.P+2 ) THEN
CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
$ DCMPLX( ONE, ZERO ), C( IS, JS ), LDC,
$ B( 1, JS ), LDB, DCMPLX( ONE, ZERO ),
$ F( IS, 1 ), LDF )
CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
$ DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
$ E( 1, JS ), LDE, DCMPLX( ONE, ZERO ),
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
$ DCMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA,
$ C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
$ C( IE+1, JS ), LDC )
CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
$ DCMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD,
$ F( IS, JS ), LDF, DCMPLX( ONE, ZERO ),
$ C( IE+1, JS ), LDC )
END IF
200 CONTINUE
210 CONTINUE
END IF
*
WORK( 1 ) = LWMIN
*
RETURN
*
* End of ZTGSYL
*
END
*> \brief \b ZTPCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTPCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztpcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztpcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztpcon.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORM, UPLO
* INTEGER INFO, N
* DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 AP( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTPCON estimates the reciprocal of the condition number of a packed
*> 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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangular matrix A, packed columnwise in
*> a linear array. The j-th column of A is stored in the array
*> AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> If DIAG = 'U', the diagonal elements of A are not referenced
*> and are assumed to be 1.
*> \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.
*
*> \ingroup tpcon
*
* =====================================================================
SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORM, UPLO
INTEGER INFO, N
DOUBLE PRECISION RCOND
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 AP( * ), 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, ZLANTP
EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANTP
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLATPS
* ..
* .. 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
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTPCON', -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 = ZLANTP( NORM, UPLO, DIAG, N, AP, 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 ZLATPS( UPLO, 'No transpose', DIAG, NORMIN, N,
$ AP,
$ WORK, SCALE, RWORK, INFO )
ELSE
*
* Multiply by inv(A**H).
*
CALL ZLATPS( UPLO, 'Conjugate transpose', DIAG,
$ NORMIN,
$ N, AP, 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 ZTPCON
*
END
*> \brief \b ZTPTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTPTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztptri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztptri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztptri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTPTRI computes the inverse of a complex upper or lower triangular
*> matrix A stored in packed format.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangular matrix A, stored
*> columnwise in a linear array. The j-th column of A is stored
*> in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
*> See below for further details.
*> On exit, the (triangular) inverse of the original matrix, in
*> the same packed storage format.
*> \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, A(i,i) is exactly zero. The triangular
*> matrix is singular and its inverse can not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tptri
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A triangular matrix A can be transferred to packed storage using one
*> of the following program segments:
*>
*> UPLO = 'U': UPLO = 'L':
*>
*> JC = 1 JC = 1
*> DO 2 J = 1, N DO 2 J = 1, N
*> DO 1 I = 1, J DO 1 I = J, N
*> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
*> 1 CONTINUE 1 CONTINUE
*> JC = JC + J JC = JC + N - J + 1
*> 2 CONTINUE 2 CONTINUE
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC, JCLAST, JJ
COMPLEX*16 AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZSCAL, ZTPMV
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTPTRI', -INFO )
RETURN
END IF
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JJ = 0
DO 10 INFO = 1, N
JJ = JJ + INFO
IF( AP( JJ ).EQ.ZERO )
$ RETURN
10 CONTINUE
ELSE
JJ = 1
DO 20 INFO = 1, N
IF( AP( JJ ).EQ.ZERO )
$ RETURN
JJ = JJ + N - INFO + 1
20 CONTINUE
END IF
INFO = 0
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
JC = 1
DO 30 J = 1, N
IF( NOUNIT ) THEN
AP( JC+J-1 ) = ONE / AP( JC+J-1 )
AJJ = -AP( JC+J-1 )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL ZTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
$ AP( JC ), 1 )
CALL ZSCAL( J-1, AJJ, AP( JC ), 1 )
JC = JC + J
30 CONTINUE
*
ELSE
*
* Compute inverse of lower triangular matrix.
*
JC = N*( N+1 ) / 2
DO 40 J = N, 1, -1
IF( NOUNIT ) THEN
AP( JC ) = ONE / AP( JC )
AJJ = -AP( JC )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL ZTPMV( 'Lower', 'No transpose', DIAG, N-J,
$ AP( JCLAST ), AP( JC+1 ), 1 )
CALL ZSCAL( N-J, AJJ, AP( JC+1 ), 1 )
END IF
JCLAST = JC
JC = JC - N + J - 2
40 CONTINUE
END IF
*
RETURN
*
* End of ZTPTRI
*
END
*> \brief \b ZTPTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTPTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztptrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztptrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztptrs.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, TRANS, UPLO
* INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTPTRS 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 stored in packed format, and B is an N-by-NRHS matrix.
*>
*> This subroutine verifies that A is nonsingular, but callers should note that only exact
*> singularity is detected. It is conceivable for one or more diagonal elements of A to be
*> subnormally tiny numbers without this subroutine signalling an error.
*>
*> If a possible loss of numerical precision due to near-singular matrices is a concern, the
*> caller should verify that A is nonsingular within some tolerance before calling this subroutine.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangular matrix A, packed columnwise in
*> a linear array. The j-th column of A is stored in the array
*> AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=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 exactly 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.
*
*> \ingroup tptrs
*
* =====================================================================
SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, TRANS, UPLO
INTEGER INFO, LDB, N, NRHS
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JC
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .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( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTPTRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity.
*
IF( NOUNIT ) THEN
IF( UPPER ) THEN
JC = 1
DO 10 INFO = 1, N
IF( AP( JC+INFO-1 ).EQ.ZERO )
$ RETURN
JC = JC + INFO
10 CONTINUE
ELSE
JC = 1
DO 20 INFO = 1, N
IF( AP( JC ).EQ.ZERO )
$ RETURN
JC = JC + N - INFO + 1
20 CONTINUE
END IF
END IF
INFO = 0
*
* Solve A * x = b, A**T * x = b, or A**H * x = b.
*
DO 30 J = 1, NRHS
CALL ZTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
30 CONTINUE
*
RETURN
*
* End of ZTPTRS
*
END
*> \brief \b ZTRCON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRCON + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrcon.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrcon.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrcon.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup trcon
*
* =====================================================================
SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
$ RWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrevc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrevc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrevc.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup trevc
*
*> \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 --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
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 ZTREVC3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREVC3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrevc3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrevc3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrevc3.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
* $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, SIDE
* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTREVC3 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.
*>
*> This uses a Level 3 BLAS version of the back transformation.
*> \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 (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of array WORK. LWORK >= max(1,2*N).
*> For optimum performance, LWORK >= N + 2*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] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (LRWORK)
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of array RWORK. LRWORK >= max(1,N).
*>
*> If LRWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the RWORK array, returns
*> this value as the first entry of the RWORK array, and no error
*> message related to LRWORK 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.
*
*> \ingroup trevc3
*
*> \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 ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL,
$ VR,
$ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
IMPLICIT NONE
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, 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 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
INTEGER NBMIN, NBMAX
PARAMETER ( NBMIN = 8, NBMAX = 128 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB
DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
COMPLEX*16 CDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV, IZAMAX
DOUBLE PRECISION DLAMCH, DZASUM
EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH,
$ DZASUM
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV,
$ ZLATRS,
$ ZGEMM, ZLASET, ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, CONJG, 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
NB = ILAENV( 1, 'ZTREVC', SIDE // HOWMNY, N, -1, -1, -1 )
MAXWRK = MAX( 1, N + 2*N*NB )
WORK(1) = MAXWRK
RWORK(1) = MAX( 1, N )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
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
ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
INFO = -14
ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREVC3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Use blocked version of back-transformation if sufficient workspace.
* Zero-out the workspace to avoid potential NaN propagation.
*
IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN
NB = (LWORK - N) / (2*N)
NB = MIN( NB, NBMAX )
CALL ZLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N )
ELSE
NB = 1
END IF
*
* Set the constants to control overflow.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
*
* Store the diagonal elements of T in working array WORK.
*
DO 20 I = 1, N
WORK( I ) = 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.
*
* IV is index of column in current block.
* Non-blocked version always uses IV=NB=1;
* blocked version starts with IV=NB, goes down to 1.
* (Note the "0-th" column is used to store the original diagonal.)
IV = NB
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 )
*
* --------------------------------------------------------
* Complex right eigenvector
*
WORK( KI + IV*N ) = CONE
*
* Form right-hand side.
*
DO 40 K = 1, KI - 1
WORK( K + IV*N ) = -T( K, KI )
40 CONTINUE
*
* Solve upper 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 + IV*N ), SCALE,
$ RWORK, INFO )
WORK( KI + IV*N ) = SCALE
END IF
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
* ------------------------------
* no back-transform: copy x to VR and normalize.
CALL ZCOPY( KI, WORK( 1 + IV*N ), 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 ) = CZERO
60 CONTINUE
*
ELSE IF( NB.EQ.1 ) THEN
* ------------------------------
* version 1: back-transform each vector with GEMV, Q*x.
IF( KI.GT.1 )
$ CALL ZGEMV( 'N', N, KI-1, CONE, VR, LDVR,
$ WORK( 1 + IV*N ), 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 )
*
ELSE
* ------------------------------
* version 2: back-transform block of vectors with GEMM
* zero out below vector
DO K = KI + 1, N
WORK( K + IV*N ) = CZERO
END DO
*
* Columns IV:NB of work are valid vectors.
* When the number of vectors stored reaches NB,
* or if this was last vector, do the GEMM
IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN
CALL ZGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE,
$ VR, LDVR,
$ WORK( 1 + (IV)*N ), N,
$ CZERO,
$ WORK( 1 + (NB+IV)*N ), N )
* normalize vectors
DO K = IV, NB
II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
END DO
CALL ZLACPY( 'F', N, NB-IV+1,
$ WORK( 1 + (NB+IV)*N ), N,
$ VR( 1, KI ), LDVR )
IV = NB
ELSE
IV = IV - 1
END IF
END IF
*
* Restore the original diagonal elements of T.
*
DO 70 K = 1, KI - 1
T( K, K ) = WORK( K )
70 CONTINUE
*
IS = IS - 1
80 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* ============================================================
* Compute left eigenvectors.
*
* IV is index of column in current block.
* Non-blocked version always uses IV=1;
* blocked version starts with IV=1, goes up to NB.
* (Note the "0-th" column is used to store the original diagonal.)
IV = 1
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 )
*
* --------------------------------------------------------
* Complex left eigenvector
*
WORK( KI + IV*N ) = CONE
*
* Form right-hand side.
*
DO 90 K = KI + 1, N
WORK( K + IV*N ) = -CONJG( T( KI, K ) )
90 CONTINUE
*
* Solve conjugate-transposed 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 + IV*N ), SCALE, RWORK, INFO )
WORK( KI + IV*N ) = SCALE
END IF
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
* ------------------------------
* no back-transform: copy x to VL and normalize.
CALL ZCOPY( N-KI+1, WORK( KI + IV*N ), 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 ) = CZERO
110 CONTINUE
*
ELSE IF( NB.EQ.1 ) THEN
* ------------------------------
* version 1: back-transform each vector with GEMV, Q*x.
IF( KI.LT.N )
$ CALL ZGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ),
$ LDVL,
$ WORK( KI+1 + IV*N ), 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 )
*
ELSE
* ------------------------------
* version 2: back-transform block of vectors with GEMM
* zero out above vector
* could go from KI-NV+1 to KI-1
DO K = 1, KI - 1
WORK( K + IV*N ) = CZERO
END DO
*
* Columns 1:IV of work are valid vectors.
* When the number of vectors stored reaches NB,
* or if this was last vector, do the GEMM
IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN
CALL ZGEMM( 'N', 'N', N, IV, N-KI+IV, CONE,
$ VL( 1, KI-IV+1 ), LDVL,
$ WORK( KI-IV+1 + (1)*N ), N,
$ CZERO,
$ WORK( 1 + (NB+1)*N ), N )
* normalize vectors
DO K = 1, IV
II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
END DO
CALL ZLACPY( 'F', N, IV,
$ WORK( 1 + (NB+1)*N ), N,
$ VL( 1, KI-IV+1 ), LDVL )
IV = 1
ELSE
IV = IV + 1
END IF
END IF
*
* Restore the original diagonal elements of T.
*
DO 120 K = KI + 1, N
T( K, K ) = WORK( K )
120 CONTINUE
*
IS = IS + 1
130 CONTINUE
END IF
*
RETURN
*
* End of ZTREVC3
*
END
*> \brief \b ZTREXC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREXC + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrexc.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrexc.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrexc.f">
*> [TXT]</a>
*> \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
*> postmultiplying 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.
*> If N == 0 arguments ILST and IFST may be any value.
*> \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 >= 1, and if
*> COMPQ = 'V', 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.
*
*> \ingroup trexc
*
* =====================================================================
SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ).AND.( N.GT.0 )) THEN
INFO = -7
ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.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 ZTRSEN
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRSEN + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrsen.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrsen.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrsen.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
* SEP, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ, JOB
* INTEGER INFO, LDQ, LDT, LWORK, M, N
* DOUBLE PRECISION S, SEP
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSEN reorders the Schur factorization of a complex matrix
*> A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
*> the leading positions on the diagonal of the upper triangular matrix
*> T, and the leading columns of Q form an orthonormal basis of the
*> corresponding right invariant subspace.
*>
*> Optionally the routine computes the reciprocal condition numbers of
*> the cluster of eigenvalues and/or the invariant subspace.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies whether condition numbers are required for the
*> cluster of eigenvalues (S) or the invariant subspace (SEP):
*> = 'N': none;
*> = 'E': for eigenvalues only (S);
*> = 'V': for invariant subspace only (SEP);
*> = 'B': for both eigenvalues and invariant subspace (S and
*> SEP).
*> \endverbatim
*>
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'V': update the matrix Q of Schur vectors;
*> = 'N': do not update Q.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> SELECT specifies the eigenvalues in the selected cluster. To
*> select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
*> \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, T is overwritten by the reordered matrix T, with the
*> selected eigenvalues as the leading diagonal elements.
*> \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 which reorders T; the leading M
*> columns of Q form an orthonormal basis for the specified
*> invariant subspace.
*> If COMPQ = 'N', Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q.
*> LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The reordered eigenvalues of T, in the same order as they
*> appear on the diagonal of T.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The dimension of the specified invariant subspace.
*> 0 <= M <= N.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION
*> If JOB = 'E' or 'B', S is a lower bound on the reciprocal
*> condition number for the selected cluster of eigenvalues.
*> S cannot underestimate the true reciprocal condition number
*> by more than a factor of sqrt(N). If M = 0 or N, S = 1.
*> If JOB = 'N' or 'V', S is not referenced.
*> \endverbatim
*>
*> \param[out] SEP
*> \verbatim
*> SEP is DOUBLE PRECISION
*> If JOB = 'V' or 'B', SEP is the estimated reciprocal
*> condition number of the specified invariant subspace. If
*> M = 0 or N, SEP = norm(T).
*> If JOB = 'N' or 'E', SEP is not referenced.
*> \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 JOB = 'N', LWORK >= 1;
*> if JOB = 'E', LWORK = max(1,M*(N-M));
*> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
*>
*> 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.
*
*> \ingroup trsen
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> ZTRSEN first collects the selected eigenvalues by computing a unitary
*> transformation Z to move them to the top left corner of T. In other
*> words, the selected eigenvalues are the eigenvalues of T11 in:
*>
*> Z**H * T * Z = ( T11 T12 ) n1
*> ( 0 T22 ) n2
*> n1 n2
*>
*> where N = n1+n2. The first
*> n1 columns of Z span the specified invariant subspace of T.
*>
*> If T has been obtained from the Schur factorization of a matrix
*> A = Q*T*Q**H, then the reordered Schur factorization of A is given by
*> A = (Q*Z)*(Z**H*T*Z)*(Q*Z)**H, and the first n1 columns of Q*Z span the
*> corresponding invariant subspace of A.
*>
*> The reciprocal condition number of the average of the eigenvalues of
*> T11 may be returned in S. S lies between 0 (very badly conditioned)
*> and 1 (very well conditioned). It is computed as follows. First we
*> compute R so that
*>
*> P = ( I R ) n1
*> ( 0 0 ) n2
*> n1 n2
*>
*> is the projector on the invariant subspace associated with T11.
*> R is the solution of the Sylvester equation:
*>
*> T11*R - R*T22 = T12.
*>
*> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
*> the two-norm of M. Then S is computed as the lower bound
*>
*> (1 + F-norm(R)**2)**(-1/2)
*>
*> on the reciprocal of 2-norm(P), the true reciprocal condition number.
*> S cannot underestimate 1 / 2-norm(P) by more than a factor of
*> sqrt(N).
*>
*> An approximate error bound for the computed average of the
*> eigenvalues of T11 is
*>
*> EPS * norm(T) / S
*>
*> where EPS is the machine precision.
*>
*> The reciprocal condition number of the right invariant subspace
*> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
*> SEP is defined as the separation of T11 and T22:
*>
*> sep( T11, T22 ) = sigma-min( C )
*>
*> where sigma-min(C) is the smallest singular value of the
*> n1*n2-by-n1*n2 matrix
*>
*> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
*>
*> I(m) is an m by m identity matrix, and kprod denotes the Kronecker
*> product. We estimate sigma-min(C) by the reciprocal of an estimate of
*> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
*> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
*>
*> When SEP is small, small changes in T can cause large changes in
*> the invariant subspace. An approximate bound on the maximum angular
*> error in the computed right invariant subspace is
*>
*> EPS * norm(T) / SEP
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M,
$ S,
$ SEP, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER COMPQ, JOB
INTEGER INFO, LDQ, LDT, LWORK, M, N
DOUBLE PRECISION S, SEP
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
INTEGER IERR, K, KASE, KS, LWMIN, N1, N2, NN
DOUBLE PRECISION EST, RNORM, SCALE
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
DOUBLE PRECISION RWORK( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION ZLANGE
EXTERNAL LSAME, ZLANGE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACN2, ZLACPY, ZTREXC,
$ ZTRSYL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
WANTQ = LSAME( COMPQ, 'V' )
*
* Set M to the number of selected eigenvalues.
*
M = 0
DO 10 K = 1, N
IF( SELECT( K ) )
$ M = M + 1
10 CONTINUE
*
N1 = M
N2 = N - M
NN = N1*N2
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
*
IF( WANTSP ) THEN
LWMIN = MAX( 1, 2*NN )
ELSE IF( LSAME( JOB, 'N' ) ) THEN
LWMIN = 1
ELSE IF( LSAME( JOB, 'E' ) ) THEN
LWMIN = MAX( 1, NN )
END IF
*
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
$ THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
INFO = -8
ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -14
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = LWMIN
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRSEN', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.N .OR. M.EQ.0 ) THEN
IF( WANTS )
$ S = ONE
IF( WANTSP )
$ SEP = ZLANGE( '1', N, N, T, LDT, RWORK )
GO TO 40
END IF
*
* Collect the selected eigenvalues at the top left corner of T.
*
KS = 0
DO 20 K = 1, N
IF( SELECT( K ) ) THEN
KS = KS + 1
*
* Swap the K-th eigenvalue to position KS.
*
IF( K.NE.KS )
$ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR )
END IF
20 CONTINUE
*
IF( WANTS ) THEN
*
* Solve the Sylvester equation for R:
*
* T11*R - R*T22 = scale*T12
*
CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
$ LDT, WORK, N1, SCALE, IERR )
*
* Estimate the reciprocal of the condition number of the cluster
* of eigenvalues.
*
RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK )
IF( RNORM.EQ.ZERO ) THEN
S = ONE
ELSE
S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
$ SQRT( RNORM ) )
END IF
END IF
*
IF( WANTSP ) THEN
*
* Estimate sep(T11,T22).
*
EST = ZERO
KASE = 0
30 CONTINUE
CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve T11*R - R*T22 = scale*X.
*
CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
ELSE
*
* Solve T11**H*R - R*T22**H = scale*X.
*
CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT,
$ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
$ IERR )
END IF
GO TO 30
END IF
*
SEP = SCALE / EST
END IF
*
40 CONTINUE
*
* Copy reordered eigenvalues to W.
*
DO 50 K = 1, N
W( K ) = T( K, K )
50 CONTINUE
*
WORK( 1 ) = LWMIN
*
RETURN
*
* End of ZTRSEN
*
END
*> \brief \b ZTRSNA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRSNA + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrsna.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrsna.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrsna.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
* LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, JOB
* INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* DOUBLE PRECISION RWORK( * ), S( * ), SEP( * )
* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSNA estimates reciprocal condition numbers for specified
*> eigenvalues and/or right eigenvectors of a complex upper triangular
*> matrix T (or of any matrix Q*T*Q**H with Q unitary).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies whether condition numbers are required for
*> eigenvalues (S) or eigenvectors (SEP):
*> = 'E': for eigenvalues only (S);
*> = 'V': for eigenvectors only (SEP);
*> = 'B': for both eigenvalues and eigenvectors (S and SEP).
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*> HOWMNY is CHARACTER*1
*> = 'A': compute condition numbers for all eigenpairs;
*> = 'S': compute condition numbers for selected eigenpairs
*> specified by the array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> If HOWMNY = 'S', SELECT specifies the eigenpairs for which
*> condition numbers are required. To select condition numbers
*> for the j-th eigenpair, SELECT(j) must be set to .TRUE..
*> If HOWMNY = 'A', SELECT is not referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> The upper triangular matrix T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,M)
*> If JOB = 'E' or 'B', VL must contain left eigenvectors of T
*> (or of any Q*T*Q**H with Q unitary), corresponding to the
*> eigenpairs specified by HOWMNY and SELECT. The eigenvectors
*> must be stored in consecutive columns of VL, as returned by
*> ZHSEIN or ZTREVC.
*> If JOB = 'V', VL is not referenced.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the array VL.
*> LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
*> \endverbatim
*>
*> \param[in] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,M)
*> If JOB = 'E' or 'B', VR must contain right eigenvectors of T
*> (or of any Q*T*Q**H with Q unitary), corresponding to the
*> eigenpairs specified by HOWMNY and SELECT. The eigenvectors
*> must be stored in consecutive columns of VR, as returned by
*> ZHSEIN or ZTREVC.
*> If JOB = 'V', VR is not referenced.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR.
*> LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (MM)
*> If JOB = 'E' or 'B', the reciprocal condition numbers of the
*> selected eigenvalues, stored in consecutive elements of the
*> array. Thus S(j), SEP(j), and the j-th columns of VL and VR
*> all correspond to the same eigenpair (but not in general the
*> j-th eigenpair, unless all eigenpairs are selected).
*> If JOB = 'V', S is not referenced.
*> \endverbatim
*>
*> \param[out] SEP
*> \verbatim
*> SEP is DOUBLE PRECISION array, dimension (MM)
*> If JOB = 'V' or 'B', the estimated reciprocal condition
*> numbers of the selected eigenvectors, stored in consecutive
*> elements of the array.
*> If JOB = 'E', SEP is not referenced.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*> MM is INTEGER
*> The number of elements in the arrays S (if JOB = 'E' or 'B')
*> and/or SEP (if JOB = 'V' or 'B'). MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The number of elements of the arrays S and/or SEP actually
*> used to store the estimated condition numbers.
*> If HOWMNY = 'A', M is set to N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LDWORK,N+6)
*> If JOB = 'E', WORK is not referenced.
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (N)
*> If JOB = 'E', RWORK 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
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trsna
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The reciprocal of the condition number of an eigenvalue lambda is
*> defined as
*>
*> S(lambda) = |v**H*u| / (norm(u)*norm(v))
*>
*> where u and v are the right and left eigenvectors of T corresponding
*> to lambda; v**H denotes the conjugate transpose of v, and norm(u)
*> denotes the Euclidean norm. These reciprocal condition numbers always
*> lie between zero (very badly conditioned) and one (very well
*> conditioned). If n = 1, S(lambda) is defined to be 1.
*>
*> An approximate error bound for a computed eigenvalue W(i) is given by
*>
*> EPS * norm(T) / S(i)
*>
*> where EPS is the machine precision.
*>
*> The reciprocal of the condition number of the right eigenvector u
*> corresponding to lambda is defined as follows. Suppose
*>
*> T = ( lambda c )
*> ( 0 T22 )
*>
*> Then the reciprocal condition number is
*>
*> SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
*>
*> where sigma-min denotes the smallest singular value. We approximate
*> the smallest singular value by the reciprocal of an estimate of the
*> one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
*> defined to be abs(T(1,1)).
*>
*> An approximate error bound for a computed right eigenvector VR(i)
*> is given by
*>
*> EPS * norm(T) / SEP(i)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL,
$ VR,
$ LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, JOB
INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION RWORK( * ), S( * ), SEP( * )
COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D0+0 )
* ..
* .. Local Scalars ..
LOGICAL SOMCON, WANTBH, WANTS, WANTSP
CHARACTER NORMIN
INTEGER I, IERR, IX, J, K, KASE, KS
DOUBLE PRECISION BIGNUM, EPS, EST, LNRM, RNRM, SCALE, SMLNUM,
$ XNORM
COMPLEX*16 CDUM, PROD
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
COMPLEX*16 DUMMY( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH, DZNRM2
COMPLEX*16 ZDOTC
EXTERNAL LSAME, IZAMAX, DLAMCH, DZNRM2,
$ ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDRSCL, ZLACN2, ZLACPY, ZLATRS,
$ ZTREXC
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, 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
*
WANTBH = LSAME( JOB, 'B' )
WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
*
SOMCON = LSAME( HOWMNY, 'S' )
*
* Set M to the number of eigenpairs for which condition numbers are
* to be computed.
*
IF( SOMCON ) 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.WANTS .AND. .NOT.WANTSP ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) 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. ( WANTS .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE IF( MM.LT.M ) THEN
INFO = -13
ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRSNA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( SOMCON ) THEN
IF( .NOT.SELECT( 1 ) )
$ RETURN
END IF
IF( WANTS )
$ S( 1 ) = ONE
IF( WANTSP )
$ SEP( 1 ) = ABS( T( 1, 1 ) )
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
KS = 1
DO 50 K = 1, N
*
IF( SOMCON ) THEN
IF( .NOT.SELECT( K ) )
$ GO TO 50
END IF
*
IF( WANTS ) THEN
*
* Compute the reciprocal condition number of the k-th
* eigenvalue.
*
PROD = ZDOTC( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
RNRM = DZNRM2( N, VR( 1, KS ), 1 )
LNRM = DZNRM2( N, VL( 1, KS ), 1 )
S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
*
END IF
*
IF( WANTSP ) THEN
*
* Estimate the reciprocal condition number of the k-th
* eigenvector.
*
* Copy the matrix T to the array WORK and swap the k-th
* diagonal element to the (1,1) position.
*
CALL ZLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
CALL ZTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, K, 1,
$ IERR )
*
* Form C = T22 - lambda*I in WORK(2:N,2:N).
*
DO 20 I = 2, N
WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
20 CONTINUE
*
* Estimate a lower bound for the 1-norm of inv(C**H). The 1st
* and (N+1)th columns of WORK are used to store work vectors.
*
SEP( KS ) = ZERO
EST = ZERO
KASE = 0
NORMIN = 'N'
30 CONTINUE
CALL ZLACN2( N-1, WORK( 1, N+1 ), WORK, EST, KASE,
$ ISAVE )
*
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.1 ) THEN
*
* Solve C**H*x = scale*b
*
CALL ZLATRS( 'Upper', 'Conjugate transpose',
$ 'Nonunit', NORMIN, N-1, WORK( 2, 2 ),
$ LDWORK, WORK, SCALE, RWORK, IERR )
ELSE
*
* Solve C*x = scale*b
*
CALL ZLATRS( 'Upper', 'No transpose', 'Nonunit',
$ NORMIN, N-1, WORK( 2, 2 ), LDWORK, WORK,
$ SCALE, RWORK, IERR )
END IF
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
*
* Multiply by 1/SCALE if doing so will not cause
* overflow.
*
IX = IZAMAX( N-1, WORK, 1 )
XNORM = CABS1( WORK( IX, 1 ) )
IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 40
CALL ZDRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 30
END IF
*
SEP( KS ) = ONE / MAX( EST, SMLNUM )
END IF
*
40 CONTINUE
KS = KS + 1
50 CONTINUE
RETURN
*
* End of ZTRSNA
*
END
*> \brief \b ZTRSYL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRSYL + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrsyl.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrsyl.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrsyl.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
* LDC, SCALE, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANA, TRANB
* INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSYL solves the complex Sylvester matrix equation:
*>
*> op(A)*X + X*op(B) = scale*C or
*> op(A)*X - X*op(B) = scale*C,
*>
*> where op(A) = A or A**H, and A and B are both upper triangular. A is
*> M-by-M and B is N-by-N; the right hand side C and the solution X are
*> M-by-N; and scale is an output scale factor, set <= 1 to avoid
*> overflow in X.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANA
*> \verbatim
*> TRANA is CHARACTER*1
*> Specifies the option op(A):
*> = 'N': op(A) = A (No transpose)
*> = 'C': op(A) = A**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] TRANB
*> \verbatim
*> TRANB is CHARACTER*1
*> Specifies the option op(B):
*> = 'N': op(B) = B (No transpose)
*> = 'C': op(B) = B**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] ISGN
*> \verbatim
*> ISGN is INTEGER
*> Specifies the sign in the equation:
*> = +1: solve op(A)*X + X*op(B) = scale*C
*> = -1: solve op(A)*X - X*op(B) = scale*C
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The order of the matrix A, and the number of rows in the
*> matrices X and C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix B, and the number of columns in the
*> matrices X and C. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,M)
*> The upper triangular 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 COMPLEX*16 array, dimension (LDB,N)
*> The upper triangular matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N right hand side matrix C.
*> On exit, C is overwritten by the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M)
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> The scale factor, scale, set <= 1 to avoid overflow in X.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> = 1: A and B have common or very close eigenvalues; perturbed
*> values were used to solve the equation (but the matrices
*> A and B are unchanged).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trsyl
*
* =====================================================================
SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
$ LDC, SCALE, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANA, TRANB
INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRNA, NOTRNB
INTEGER J, K, L
DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
$ SMLNUM
COMPLEX*16 A11, SUML, SUMR, VEC, X11
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANGE
COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU,
$ ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test input parameters
*
NOTRNA = LSAME( TRANA, 'N' )
NOTRNB = LSAME( TRANB, 'N' )
*
INFO = 0
IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN
INFO = -2
ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) 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 = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRSYL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
SCALE = ONE
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Set constants to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
SMLNUM = SMLNUM*DBLE( M*N ) / EPS
BIGNUM = ONE / SMLNUM
SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ),
$ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) )
SGN = ISGN
*
IF( NOTRNA .AND. NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* M L-1
* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
* I=K+1 J=1
*
DO 30 L = 1, N
DO 20 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
VEC = C( K, L ) - ( SUML+SGN*SUMR )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*B( L, L )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 10 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
10 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
20 CONTINUE
30 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
*
* Solve A**H *X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* upper-left corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1 L-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
* I=1 J=1
*
DO 60 L = 1, N
DO 50 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
VEC = C( K, L ) - ( SUML+SGN*SUMR )
*
SCALOC = ONE
A11 = DCONJG( A( K, K ) ) + SGN*B( L, L )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 40 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
40 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
50 CONTINUE
60 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A**H*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* upper-right corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] +
* I=1
* N
* ISGN*SUM [X(K,J)*B**H(L,J)].
* J=L+1
*
DO 90 L = N, 1, -1
DO 80 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 70 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
80 CONTINUE
90 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
* I=K+1 J=L+1
*
DO 120 L = N, 1, -1
DO 110 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
110 CONTINUE
120 CONTINUE
*
END IF
*
RETURN
*
* End of ZTRSYL
*
END
*> \brief \b ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTI2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrti2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrti2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrti2.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRTI2 computes the inverse of a complex upper or lower triangular
*> matrix.
*>
*> This is the Level 2 BLAS version of the algorithm.
*> \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] 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] 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 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.
*>
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \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
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trti2
*
* =====================================================================
SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
COMPLEX*16 AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZSCAL, ZTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN
CALL XERBLA( 'ZTRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of ZTRTI2
*
END
*> \brief \b ZTRTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTRI + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrtri.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrtri.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrtri.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRTRI computes the inverse of a complex upper or lower triangular
*> matrix A.
*>
*> This is the Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \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,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, 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.
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \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, A(i,i) is exactly zero. The triangular
*> matrix is singular and its inverse can not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trtri
*
* =====================================================================
SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
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 ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, '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.NE.0 ) THEN
CALL XERBLA( 'ZTRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG,
$ J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG,
$ J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZTRTRI
*
END
*> \brief \b ZTRTRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTRS + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztrtrs.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztrtrs.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztrtrs.f">
*> [TXT]</a>
*> \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.
*>
*> This subroutine verifies that A is nonsingular, but callers should note that only exact
*> singularity is detected. It is conceivable for one or more diagonal elements of A to be
*> subnormally tiny numbers without this subroutine signalling an error.
*>
*> If a possible loss of numerical precision due to near-singular matrices is a concern, the
*> caller should verify that A is nonsingular within some tolerance before calling this subroutine.
*> \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 exactly 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.
*
*> \ingroup trtrs
*
* =====================================================================
SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2l.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2l.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2l.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ung2l
*
* =====================================================================
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, ZLARF1L, 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 ZLARF1L( '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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zung2r.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zung2r.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zung2r.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, ZLARF1F, 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
CALL ZLARF1F( '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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungbr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungbr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungbr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungbr
*
* =====================================================================
SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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
EXTERNAL LSAME
* ..
* .. 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, 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, LDA, TAU, WORK, -1,
$ IINFO )
END IF
END IF
END IF
LWKOPT = INT( DBLE( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunghr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunghr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunghr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unghr
*
* =====================================================================
SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungl2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungl2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungl2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungl2
*
* =====================================================================
SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, ZLARF1F, 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
CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ CONJG( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunglq.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunglq.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunglq.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unglq
*
* =====================================================================
SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungql.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungql.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungql.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungql
*
* =====================================================================
SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungqr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungqr
*
* =====================================================================
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungr2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungr2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungr2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungr2
*
* =====================================================================
SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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, ZLARF1L, 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 )
CALL ZLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
$ CONJG( 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungrq.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungrq.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungrq.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungrq
*
* =====================================================================
SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zungtr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zungtr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zungtr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup ungtr
*
* =====================================================================
SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNM2L + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunm2l.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunm2l.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunm2l.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNM2L( 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
*>
*> ZUNM2L 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(2) H(1)
*>
*> as returned by ZGEQLF. 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
*> ZGEQLF in the last 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 ZGEQLF.
*> \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.
*
*> \ingroup unm2l
*
* =====================================================================
SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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, MI, NI, NQ
COMPLEX*16 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF1L
* ..
* .. 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( 'ZUNM2L', -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
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
CALL ZLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC,
$ WORK )
10 CONTINUE
RETURN
*
* End of ZUNM2L
*
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunm2r.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunm2r.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunm2r.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF1F
* ..
* .. 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
CALL ZLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ),
$ LDC,
$ WORK )
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmbr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmbr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmbr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unmbr
*
* =====================================================================
SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, M )
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.NW .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( M.GT.0 .AND. N.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 = 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmhr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmhr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmhr.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unmhr
*
* =====================================================================
SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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.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 = 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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunml2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunml2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunml2.f">
*> [TXT]</a>
*> \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.
*
*> \ingroup unml2
*
* =====================================================================
SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER 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 TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF1F
* ..
* .. 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 )
CALL ZLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC,
$ JC ), LDC, WORK )
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
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmlq.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmlq.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmlq.f">
*> [TXT]</a>
*> \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 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] 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.
*
*> \ingroup unmlq
*
* =====================================================================
SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
LWKOPT = NW*NB + TSIZE
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
IF( LWORK.LT.LWKOPT ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
END IF
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
*
IWT = 1 + NW*NB
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 ), WORK( IWT ), 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, WORK( IWT ), LDT,
$ C( IC, JC ), LDC, WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMLQ
*
END
*> \brief \b ZUNMQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMQL + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmql.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmql.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmql.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMQL( 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
*>
*> ZUNMQL 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(2) H(1)
*>
*> as returned by ZGEQLF. 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
*> ZGEQLF in the last 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 ZGEQLF.
*> \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 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] 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.
*
*> \ingroup unmql
*
* =====================================================================
SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L
* ..
* .. 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M,
$ N,
$ K, -1 ) )
LWKOPT = NW*NB + TSIZE
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQL', -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
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IF( LWORK.LT.LWKOPT ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IWT = 1 + NW*NB
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
ELSE
MI = M
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+ib-1) . . . H(i+1) H(i)
*
CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H**H is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI,
$ NI,
$ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQL
*
END
*> \brief \b ZUNMQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMQR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmqr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmqr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmqr.f">
*> [TXT]</a>
*> \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 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] 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.
*
*> \ingroup unmqr
*
* =====================================================================
SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. 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 = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, 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.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
LWKOPT = NW*NB + TSIZE
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
IF( LWORK.LT.LWKOPT ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
END IF
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
*
IWT = 1 + NW*NB
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 ), WORK( IWT ), 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, WORK( IWT ), LDT,
$ C( IC, JC ), LDC, WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQR
*
END
*> \brief \b ZUNMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMTR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunmtr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunmtr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunmtr.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, UPLO
* INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMTR 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
*> nq-1 elementary reflectors, as returned by ZHETRD:
*>
*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-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] 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] 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] 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 ZHETRD.
*> \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 ZHETRD.
*> \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.
*
*> \ingroup unmtr
*
* =====================================================================
SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C,
$ LDC,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMQL, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .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( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
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
END IF
LWKOPT = NW*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = M - 1
NI = N
ELSE
MI = M
NI = N - 1
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHETRD with UPLO = 'U'
*
CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU,
$ C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to ZHETRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
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
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMTR
*
END
*> \brief \b ZUPGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUPGTR + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zupgtr.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zupgtr.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zupgtr.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUPGTR generates a complex unitary matrix Q which is defined as the
*> product of n-1 elementary reflectors H(i) of order n, as returned by
*> ZHPTRD using packed storage:
*>
*> 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 triangular packed storage used in previous
*> call to ZHPTRD;
*> = 'L': Lower triangular packed storage used in previous
*> call to ZHPTRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The vectors which define the elementary reflectors, as
*> returned by ZHPTRD.
*> \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 ZHPTRD.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> The N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N-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.
*
*> \ingroup upgtr
*
* =====================================================================
SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNG2L, ZUNG2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
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( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = CZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = CZERO
30 CONTINUE
Q( N, N ) = CONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = CONE
DO 40 I = 2, N
Q( I, 1 ) = CZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = CZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of ZUPGTR
*
END