*> \brief \b CAXPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY)
*
* .. Scalar Arguments ..
* COMPLEX CA
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*),CY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CAXPY constant times a vector plus a vector.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] CA
*> \verbatim
*> CA is COMPLEX
*> On entry, CA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of CY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup axpy
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX CA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX CX(*),CY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY
* ..
* .. External Functions ..
REAL SCABS1
EXTERNAL SCABS1
* ..
IF (N.LE.0) RETURN
IF (SCABS1(CA).EQ.0.0E+0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
CY(I) = CY(I) + CA*CX(I)
END DO
ELSE
*
* 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 I = 1,N
CY(IY) = CY(IY) + CA*CX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
*
RETURN
*
* End of CAXPY
*
END
*> \brief \b CCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CCOPY(N,CX,INCX,CY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*),CY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CCOPY copies a vector x to a vector y.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*>
*> \param[out] CY
*> \verbatim
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of CY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup copy
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CCOPY(N,CX,INCX,CY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
* ..
* .. Array Arguments ..
COMPLEX CX(*),CY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
CY(I) = CX(I)
END DO
ELSE
*
* 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 I = 1,N
CY(IY) = CX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of CCOPY
*
END
*> \brief \b CDOTC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*),CY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CDOTC forms the dot product of two complex vectors
*> CDOTC = X^H * Y
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*>
*> \param[in] CY
*> \verbatim
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of CY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup dot
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
* ..
* .. Array Arguments ..
COMPLEX CX(*),CY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
COMPLEX CTEMP
INTEGER I,IX,IY
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
CTEMP = (0.0,0.0)
CDOTC = (0.0,0.0)
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
CTEMP = CTEMP + CONJG(CX(I))*CY(I)
END DO
ELSE
*
* 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 I = 1,N
CTEMP = CTEMP + CONJG(CX(IX))*CY(IY)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
CDOTC = CTEMP
RETURN
*
* End of CDOTC
*
END
*> \brief \b CGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CGEMM performs one of the matrix-matrix operations
*>
*> C := alpha*op( A )*op( B ) + beta*C,
*>
*> where op( X ) is one of
*>
*> op( X ) = X or op( X ) = X**T or op( X ) = X**H,
*>
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA specifies the form of op( A ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSA = 'N' or 'n', op( A ) = A.
*>
*> TRANSA = 'T' or 't', op( A ) = A**T.
*>
*> TRANSA = 'C' or 'c', op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] TRANSB
*> \verbatim
*> TRANSB is CHARACTER*1
*> On entry, TRANSB specifies the form of op( B ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSB = 'N' or 'n', op( B ) = B.
*>
*> TRANSB = 'T' or 't', op( B ) = B**T.
*>
*> TRANSB = 'C' or 'c', op( B ) = B**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix
*> op( A ) and of the matrix C. M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix
*> op( B ) and the number of columns of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry, K specifies the number of columns of the matrix
*> op( A ) and the number of rows of the matrix op( B ). K must
*> be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANSA = 'N' or 'n', and is m otherwise.
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
*> part of the array A must contain the matrix A, otherwise
*> the leading k by m part of the array A must contain the
*> matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
*> LDA must be at least max( 1, m ), otherwise LDA must be at
*> least max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> n when TRANSB = 'N' or 'n', and is k otherwise.
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
*> part of the array B must contain the matrix B, otherwise
*> the leading n by k part of the array B must contain the
*> matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
*> LDB must be at least max( 1, k ), otherwise LDB must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then C need not be set on input.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> Before entry, the leading m by n part of the array C must
*> contain the matrix C, except when beta is zero, in which
*> case C need not be set on entry.
*> On exit, the array C is overwritten by the m by n matrix
*> ( alpha*op( A )*op( B ) + beta*C ).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemm
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,
+ BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,J,L,NROWA,NROWB
LOGICAL CONJA,CONJB,NOTA,NOTB
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Set NOTA and NOTB as true if A and B respectively are not
* conjugated or transposed, set CONJA and CONJB as true if A and
* B respectively are to be transposed but not conjugated and set
* NROWA and NROWB as the number of rows of A and B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
CONJA = LSAME(TRANSA,'C')
CONJB = LSAME(TRANSB,'C')
IF (NOTA) THEN
NROWA = M
ELSE
NROWA = K
END IF
IF (NOTB) THEN
NROWB = K
ELSE
NROWB = N
END IF
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND.
+ (.NOT.LSAME(TRANSA,'T'))) THEN
INFO = 1
ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND.
+ (.NOT.LSAME(TRANSB,'T'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 8
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
INFO = 10
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CGEMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (NOTB) THEN
IF (NOTA) THEN
*
* Form C := alpha*A*B + beta*C.
*
DO 90 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 50 I = 1,M
C(I,J) = ZERO
50 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 60 I = 1,M
C(I,J) = BETA*C(I,J)
60 CONTINUE
END IF
DO 80 L = 1,K
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
80 CONTINUE
90 CONTINUE
ELSE IF (CONJA) THEN
*
* Form C := alpha*A**H*B + beta*C.
*
DO 120 J = 1,N
DO 110 I = 1,M
TEMP = ZERO
DO 100 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*B(L,J)
100 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
110 CONTINUE
120 CONTINUE
ELSE
*
* Form C := alpha*A**T*B + beta*C
*
DO 150 J = 1,N
DO 140 I = 1,M
TEMP = ZERO
DO 130 L = 1,K
TEMP = TEMP + A(L,I)*B(L,J)
130 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
140 CONTINUE
150 CONTINUE
END IF
ELSE IF (NOTA) THEN
IF (CONJB) THEN
*
* Form C := alpha*A*B**H + beta*C.
*
DO 200 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 160 I = 1,M
C(I,J) = ZERO
160 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 170 I = 1,M
C(I,J) = BETA*C(I,J)
170 CONTINUE
END IF
DO 190 L = 1,K
TEMP = ALPHA*CONJG(B(J,L))
DO 180 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
180 CONTINUE
190 CONTINUE
200 CONTINUE
ELSE
*
* Form C := alpha*A*B**T + beta*C
*
DO 250 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 210 I = 1,M
C(I,J) = ZERO
210 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 220 I = 1,M
C(I,J) = BETA*C(I,J)
220 CONTINUE
END IF
DO 240 L = 1,K
TEMP = ALPHA*B(J,L)
DO 230 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
230 CONTINUE
240 CONTINUE
250 CONTINUE
END IF
ELSE IF (CONJA) THEN
IF (CONJB) THEN
*
* Form C := alpha*A**H*B**H + beta*C.
*
DO 280 J = 1,N
DO 270 I = 1,M
TEMP = ZERO
DO 260 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L))
260 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
270 CONTINUE
280 CONTINUE
ELSE
*
* Form C := alpha*A**H*B**T + beta*C
*
DO 310 J = 1,N
DO 300 I = 1,M
TEMP = ZERO
DO 290 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*B(J,L)
290 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
300 CONTINUE
310 CONTINUE
END IF
ELSE
IF (CONJB) THEN
*
* Form C := alpha*A**T*B**H + beta*C
*
DO 340 J = 1,N
DO 330 I = 1,M
TEMP = ZERO
DO 320 L = 1,K
TEMP = TEMP + A(L,I)*CONJG(B(J,L))
320 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
330 CONTINUE
340 CONTINUE
ELSE
*
* Form C := alpha*A**T*B**T + beta*C
*
DO 370 J = 1,N
DO 360 I = 1,M
TEMP = ZERO
DO 350 L = 1,K
TEMP = TEMP + A(L,I)*B(J,L)
350 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
360 CONTINUE
370 CONTINUE
END IF
END IF
*
RETURN
*
* End of CGEMM
*
END
*> \brief \b CGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CGEMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
*>
*> y := alpha*A**H*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
*>
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients.
*> \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, m ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*> Before entry, the incremented array X must contain the
*> vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*> Before entry with BETA non-zero, the incremented array Y
*> must contain the vector y. On exit, Y is overwritten by the
*> updated vector y.
*> If either m or n is zero, then Y not referenced and the function
*> performs a quick return.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
LOGICAL NOCONJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) 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 = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
ELSE IF (INCY.EQ.0) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CGEMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
NOCONJ = LSAME(TRANS,'T')
*
* Set LENX and LENY, the lengths of the vectors x and y, and set
* up the start points in X and Y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
ELSE
LENX = M
LENY = N
END IF
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (LENX-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through 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,LENY
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
TEMP = ALPHA*X(JX)
DO 50 I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
TEMP = ALPHA*X(JX)
IY = KY
DO 70 I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = ZERO
IF (NOCONJ) THEN
DO 90 I = 1,M
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
ELSE
DO 100 I = 1,M
TEMP = TEMP + CONJG(A(I,J))*X(I)
100 CONTINUE
END IF
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
110 CONTINUE
ELSE
DO 140 J = 1,N
TEMP = ZERO
IX = KX
IF (NOCONJ) THEN
DO 120 I = 1,M
TEMP = TEMP + A(I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
ELSE
DO 130 I = 1,M
TEMP = TEMP + CONJG(A(I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
END IF
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
140 CONTINUE
END IF
END IF
*
RETURN
*
* End of CGEMV
*
END
*> \brief \b CGERC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CGERC performs the rank 1 operation
*>
*> A := alpha*x*y**H + A,
*>
*> where alpha is a scalar, x is an m element vector, y is an n element
*> vector and A is an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the m
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element 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.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients. On exit, A is
*> overwritten by 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, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ger
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (M.LT.0) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (INCY.EQ.0) THEN
INFO = 7
ELSE IF (LDA.LT.MAX(1,M)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CGERC ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (INCY.GT.0) THEN
JY = 1
ELSE
JY = 1 - (N-1)*INCY
END IF
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*CONJG(Y(JY))
DO 10 I = 1,M
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
JY = JY + INCY
20 CONTINUE
ELSE
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (M-1)*INCX
END IF
DO 40 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*CONJG(Y(JY))
IX = KX
DO 30 I = 1,M
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JY = JY + INCY
40 CONTINUE
END IF
*
RETURN
*
* End of CGERC
*
END
*> \brief CHEEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHEEVD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHEEVD( 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( * )
* REAL RWORK( * ), W( * )
* COMPLEX A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHEEVD 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 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 REAL array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The 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 REAL 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 CHEEVD( 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( * )
REAL RWORK( * ), W( * )
COMPLEX A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
COMPLEX CONE
PARAMETER ( CONE = ( 1.0E0, 0.0E0 ) )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2,
$ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
$ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL CLANHE, SLAMCH, SROUNDUP_LWORK
EXTERNAL ILAENV, LSAME, CLANHE, SLAMCH,
$ SROUNDUP_LWORK
* ..
* .. External Subroutines ..
EXTERNAL CHETRD, CLACPY, CLASCL, CSTEDC, CUNMTR,
$ SSCAL,
$ SSTERF, XERBLA
* ..
* .. 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, 'CHETRD', UPLO, N, -1, -1,
$ -1 ) )
LROPT = LRWMIN
LIOPT = LIWMIN
END IF
WORK( 1 ) = SROUNDUP_LWORK( LOPT )
RWORK( 1 ) = SROUNDUP_LWORK( 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( 'CHEEVD', -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 ) = REAL( A( 1, 1 ) )
IF( WANTZ )
$ A( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = CLANHE( '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 CLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call CHETRD 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 CHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call SSTERF. For eigenvectors, first call
* CSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call CUNMTR to multiply it to the
* Householder transformations represented as Householder vectors in
* A.
*
IF( .NOT.WANTZ ) THEN
CALL SSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
$ IWORK, LIWORK, INFO )
CALL CUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL CLACPY( '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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
WORK( 1 ) = SROUNDUP_LWORK( LOPT )
RWORK( 1 ) = SROUNDUP_LWORK( LROPT )
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of CHEEVD
*
END
*> \brief \b CHEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHEMV 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 hermitian 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX 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 hermitian 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 hermitian matrix 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
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX 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.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup hemv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
*
* 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('CHEMV ',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 + CONJG(A(I,J))*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*REAL(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 + CONJG(A(I,J))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*REAL(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*REAL(A(J,J))
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + CONJG(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*REAL(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 + CONJG(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 CHEMV
*
END
*> \brief \b CHER2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2 performs the hermitian rank 2 operation
*>
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an n
*> by n hermitian 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element 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.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX 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 hermitian 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 hermitian 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.
*> 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
*>
*> \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 ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup her2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
*
* 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 (INCY.EQ.0) THEN
INFO = 7
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHER2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
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
JX = KX
JY = KY
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 the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
DO 10 I = 1,J - 1
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
A(J,J) = REAL(A(J,J)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
ELSE
A(J,J) = REAL(A(J,J))
END IF
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
IX = KX
IY = KY
DO 30 I = 1,J - 1
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
A(J,J) = REAL(A(J,J)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
A(J,J) = REAL(A(J,J)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
DO 50 I = J + 1,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
A(J,J) = REAL(A(J,J)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
IX = JX
IY = JY
DO 70 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
70 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHER2
*
END
*> \brief \b CHER2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* REAL BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2K performs one of the hermitian rank 2k operations
*>
*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
*>
*> where alpha and beta are scalars with beta real, C is an n by n
*> hermitian matrix and A and B are n by k matrices in the first case
*> and k by n matrices in the second case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the array C is to be referenced as
*> follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of C
*> is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of C
*> is to be referenced.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*B**H +
*> conjg( alpha )*B*A**H +
*> beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**H*B +
*> conjg( alpha )*B**H*A +
*> beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with TRANS = 'N' or 'n', K specifies the number
*> of columns of the matrices A and B, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrices A and B. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> Before entry with TRANS = 'N' or 'n', the leading n by k
*> part of the array A must contain the matrix A, otherwise
*> the leading k by n part of the array A must contain the
*> matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When TRANS = 'N' or 'n'
*> then LDA must be at least max( 1, n ), otherwise LDA must
*> be at least max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> Before entry with TRANS = 'N' or 'n', the leading n by k
*> part of the array B must contain the matrix B, otherwise
*> the leading k by n part of the array B must contain the
*> matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. When TRANS = 'N' or 'n'
*> then LDB must be at least max( 1, n ), otherwise LDB must
*> be at least max( 1, k ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array C must contain the upper
*> triangular part of the hermitian matrix and the strictly
*> lower triangular part of C is not referenced. On exit, the
*> upper triangular part of the array C 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 C must contain the lower
*> triangular part of the hermitian matrix and the strictly
*> upper triangular part of C is not referenced. On exit, the
*> lower triangular part of the array C 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
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup her2k
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*>
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
REAL BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE
PARAMETER (ONE=1.0E+0)
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 1
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ (.NOT.LSAME(TRANS,'C'))) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHER2K',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J - 1
C(I,J) = BETA*C(I,J)
30 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
C(J,J) = BETA*REAL(C(J,J))
DO 70 I = J + 1,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
* C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.REAL(ZERO)) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J - 1
C(I,J) = BETA*C(I,J)
100 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(B(J,L))
TEMP2 = CONJG(ALPHA*A(J,L))
DO 110 I = 1,J - 1
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
C(J,J) = REAL(C(J,J)) +
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.REAL(ZERO)) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J + 1,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(B(J,L))
TEMP2 = CONJG(ALPHA*A(J,L))
DO 160 I = J + 1,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
C(J,J) = REAL(C(J,J)) +
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
* C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP1 = ZERO
TEMP2 = ZERO
DO 190 L = 1,K
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
190 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
C(J,J) = REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*REAL(C(J,J)) +
+ REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ CONJG(ALPHA)*TEMP2
END IF
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP1 = ZERO
TEMP2 = ZERO
DO 220 L = 1,K
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
220 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
C(J,J) = REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*REAL(C(J,J)) +
+ REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ CONJG(ALPHA)*TEMP2
END IF
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHER2K
*
END
*> \brief \b CHETD2 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 CHETD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * )
* COMPLEX A( LDA, * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETD2 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 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 REAL array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is REAL 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 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 CHETD2( 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 ..
REAL D( * ), E( * )
COMPLEX A( LDA, * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
$ ZERO = ( 0.0E+0, 0.0E+0 ),
$ HALF = ( 0.5E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
COMPLEX ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL CAXPY, CHEMV, CHER2, CLARFG, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX CDOTC
EXTERNAL LSAME, CDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, REAL
* ..
* .. 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( 'CHETD2', -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 ) = REAL( 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 CLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
E( I ) = REAL( 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 CHEMV( 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*CDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
CALL CAXPY( 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 CHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
ELSE
A( I, I ) = REAL( A( I, I ) )
END IF
A( I, I+1 ) = E( I )
D( I+1 ) = REAL( A( I+1, I+1 ) )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = REAL( A( 1, 1 ) )
ELSE
*
* Reduce the lower triangle of A
*
A( 1, 1 ) = REAL( 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 CLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
E( I ) = REAL( 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 CHEMV( 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*CDOTC( N-I, TAU( I ), 1, A( I+1,
$ I ),
$ 1 )
CALL CAXPY( 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 CHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ),
$ 1,
$ A( I+1, I+1 ), LDA )
*
ELSE
A( I+1, I+1 ) = REAL( A( I+1, I+1 ) )
END IF
A( I+1, I ) = E( I )
D( I ) = REAL( A( I, I ) )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = REAL( A( N, N ) )
END IF
*
RETURN
*
* End of CHETD2
*
END
*> \brief \b CHETRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHETRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * )
* COMPLEX A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHETRD 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 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 REAL array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is REAL 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 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 1.
*> 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 CHETRD( 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 ..
REAL D( * ), E( * )
COMPLEX A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E+0 )
COMPLEX CONE
PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL CHER2K, CHETD2, CLATRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SROUNDUP_LWORK
EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK
* ..
* .. 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, 'CHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, N*NB )
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CHETRD', -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, 'CHETRD', 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, 'CHETRD', 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 CLATRD( 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 CHER2K( 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 ) = REAL( A( J, J ) )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL CHETD2( 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 CLATRD( 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 CHER2K( 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 ) = REAL( A( J, J ) )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL CHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
RETURN
*
* End of CHETRD
*
END
*> \brief \b CLACGV conjugates a complex vector.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLACGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLACGV( N, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLACGV 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 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 CLACGV( 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 X( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = CONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = CONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of CLACGV
*
END
*> \brief \b CLACPY 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 CLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLACPY 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 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 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 CLACPY( 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 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 CLACPY
*
END
*> \brief \b CLACRM multiplies a complex matrix by a square real matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLACRM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
* REAL B( LDB, * ), RWORK( * )
* COMPLEX A( LDA, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLACRM 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 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 REAL 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 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 REAL 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 CLACRM( 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 ..
REAL B( LDB, * ), RWORK( * )
COMPLEX A( LDA, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. Intrinsic Functions ..
INTRINSIC AIMAG, CMPLX, REAL
* ..
* .. External Subroutines ..
EXTERNAL SGEMM
* ..
* .. 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 ) = REAL( A( I, J ) )
10 CONTINUE
20 CONTINUE
*
L = M*N + 1
CALL SGEMM( '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 ) = AIMAG( A( I, J ) )
50 CONTINUE
60 CONTINUE
CALL SGEMM( '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 ) = CMPLX( REAL( C( I, J ) ),
$ RWORK( L+( J-1 )*M+I-1 ) )
70 CONTINUE
80 CONTINUE
*
RETURN
*
* End of CLACRM
*
END
*> \brief \b CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* COMPLEX FUNCTION CLADIV( X, Y )
*
* .. Scalar Arguments ..
* COMPLEX X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLADIV := 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
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX
*> 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 FUNCTION CLADIV( 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 X, Y
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL SLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC AIMAG, CMPLX, REAL
* ..
* .. Executable Statements ..
*
CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
$ ZI )
CLADIV = CMPLX( ZR, ZI )
*
RETURN
*
* End of CLADIV
*
END
*> \brief \b CLAED0 used by CSTEDC. 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 CLAED0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
* IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* REAL D( * ), E( * ), RWORK( * )
* COMPLEX Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Using the divide and conquer method, CLAED0 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 REAL 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 REAL 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 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 REAL 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 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 CLAED0( 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( * )
REAL D( * ), E( * ), RWORK( * )
COMPLEX Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
* =====================================================================
*
* Warning: N could be as big as QSIZ!
*
* .. Parameters ..
REAL TWO
PARAMETER ( TWO = 2.E+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
REAL TEMP
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CLACRM, CLAED7, SCOPY, SSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, REAL
* ..
* .. 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( 'CLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'CLAED0', ' ', 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( REAL( 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 SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ RWORK( LL ), MATSIZ, RWORK, INFO )
CALL CLACRM( 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. CLAED7 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 CLAED7( 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 CCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL SCOPY( N, RWORK, 1, D, 1 )
*
RETURN
*
* End of CLAED0
*
END
*> \brief \b CLAED7 used by CSTEDC. 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 CLAED7 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLAED7( 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
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
* REAL D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
* COMPLEX Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLAED7 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 SLAED2.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine SLAED4 (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 REAL 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 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 REAL
*> 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 REAL array,
*> dimension (3*N+2*QSIZ*N)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX array, dimension (QSIZ*N)
*> \endverbatim
*>
*> \param[in,out] QSTORE
*> \verbatim
*> QSTORE is REAL 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 REAL 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 CLAED7( 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
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
REAL D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
COMPLEX Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX,
$ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG,
$ XERBLA
* ..
* .. 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( 'CLAED7', -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 SLAED2 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 SLAEDA( 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 CLAED8( 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 SLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
$ RWORK( IDLMDA ), RWORK( IW ),
$ QSTORE( QPTR( CURR ) ), K, INFO )
CALL CLACRM( 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 SLAMRG( 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 CLAED7
*
END
*> \brief \b CLAED8 used by CSTEDC. 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 CLAED8 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLAED8( 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
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
* $ INDXQ( * ), PERM( * )
* REAL D( * ), DLAMBDA( * ), GIVNUM( 2, * ), W( * ),
* $ Z( * )
* COMPLEX Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLAED8 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 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 REAL 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 REAL
*> 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 SLAED3.
*> \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 REAL 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 REAL array, dimension (N)
*> Contains a copy of the first K eigenvalues which will be used
*> by SLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is COMPLEX 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 SLAED7 in a matrix multiply (SGEMM) 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 REAL array, dimension (N)
*> This will hold the first k values of the final
*> deflation-altered z-vector and will be passed to SLAED3.
*> \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 REAL 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 CLAED8( 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
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
REAL D( * ), DLAMBDA( * ), GIVNUM( 2, * ), W( * ),
$ Z( * )
COMPLEX Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CLACPY, CSROT, SCOPY, SLAMRG,
$ SSCAL,
$ XERBLA
* ..
* .. 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( 'CLAED8', -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 SSCAL( 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 SSCAL( 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 SLAMRG( 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 = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( '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 CCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
50 CONTINUE
CALL CLACPY( '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 = SLAPY2( 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 CSROT( 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 CCOPY( 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 SCOPY( N-K, DLAMBDA( K+1 ), 1, D( K+1 ), 1 )
CALL CLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1,
$ K+1 ),
$ LDQ )
END IF
*
RETURN
*
* End of CLAED8
*
END
*> \brief \b CLANHE 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 CLANHE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER LDA, N
* ..
* .. Array Arguments ..
* REAL WORK( * )
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLANHE 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 CLANHE
*> \verbatim
*>
*> CLANHE = ( 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 CLANHE 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, CLANHE is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX 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 REAL 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
*
* =====================================================================
REAL FUNCTION CLANHE( 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 ..
REAL WORK( * )
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
REAL ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME, SISNAN
EXTERNAL LSAME, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL CLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, REAL, 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. SISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
SUM = ABS( REAL( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
DO 40 J = 1, N
SUM = ABS( REAL( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM
DO 30 I = J + 1, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. SISNAN( 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( REAL( A( J, J ) ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. SISNAN( 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( REAL( 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. SISNAN( 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 CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
120 CONTINUE
END IF
SUM = 2*SUM
DO 130 I = 1, N
IF( REAL( A( I, I ) ).NE.ZERO ) THEN
ABSA = ABS( REAL( 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
*
CLANHE = VALUE
RETURN
*
* End of CLANHE
*
END
*> \brief \b CLARF1F 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 CLARF1F + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX TAU
* ..
* .. Array Arguments ..
* COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARF1F 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 assuming v(1) = 1.
*>
*> 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 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
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CLARF1F( 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 TAU
* ..
* .. Array Arguments ..
COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CGER, CSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILACLR, ILACLC
EXTERNAL LSAME, ILACLR, ILACLC
* ..
* .. 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 up to V(1).
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.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 = ILACLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILACLR(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.1 ) THEN
*
* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
*
CALL CSCAL( LASTC, ONE - TAU, C, LDC )
ELSE
*
* w(1:lastc,1) := C(2:lastv,1:lastc)**H * v(2:lastv,1)
*
CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, ONE,
$ C( 2, 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 ) + CONJG( C( 1, I ) )
END DO
*
* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**H
*
DO I = 1, LASTC
C( 1, I ) = C( 1, I ) - TAU * CONJG( WORK( I ) )
END DO
*
* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H
*
CALL CGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV,
$ WORK, 1, C( 2, 1 ), LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.EQ.1 ) THEN
*
* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
*
CALL CSCAL( LASTC, ONE - TAU, C, 1 )
ELSE
*
* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
*
CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE,
$ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO,
$ WORK, 1 )
*
* w(1:lastc,1) += v(1,1) * C(1:lastc,1)
*
CALL CAXPY( LASTC, ONE, C, 1, WORK, 1 )
*
* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1)
*
CALL CAXPY( LASTC, -TAU, WORK, 1, C, 1 )
*
* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**H
*
CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1,
$ V( 1 + INCV ), INCV, C( 1, 2 ), LDC )
END IF
END IF
RETURN
*
* End of CLARF1F
*
END
*> \brief \b CLARF1L 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 CLARF1L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX TAU
* ..
* .. Array Arguments ..
* COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARF1L 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 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
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CLARF1L( 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 TAU
* ..
* .. Array Arguments ..
COMPLEX C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ),
$ ZERO = ( 0.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, J, LASTV, LASTC, FIRSTV
* ..
* .. External Subroutines ..
EXTERNAL CGEMV, CGERC, CSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILACLR, ILACLC
EXTERNAL LSAME, ILACLR, ILACLC
* ..
* .. 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 = ILACLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILACLR(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 CSCAL( 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 CGEMV( '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 CGERC( 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 CSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 )
ELSE
*
* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1)
*
CALL CGEMV( '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 CAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 )
*
* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1)
*
CALL CAXPY( 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 CGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ),
$ INCV, C( 1, FIRSTV ), LDC )
END IF
END IF
RETURN
*
* End of CLARF1L
*
END
*> \brief \b CLARFB 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 CLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARFB( 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 C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFB 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 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = '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' 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 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 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 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 CLARFB( 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 C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
* .. 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 CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H *V2
*
CALL CGEMM( '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 CTRMM( '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 CGEMM( '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 CTRMM( '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 ) - CONJG( 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 CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
$ M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL CGEMM( '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 CTRMM( '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 CGEMM( '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 CTRMM( '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 CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ),
$ 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL CTRMM( '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 CGEMM( '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 CTRMM( '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 CGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( '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 ) -
$ CONJG( 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 CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL CTRMM( '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 CGEMM( '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 CTRMM( '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 CGEMM( 'No transpose', 'Conjugate transpose',
$ M,
$ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
$ C, LDC )
END IF
*
* W := W * V2**H
*
CALL CTRMM( '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 CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2**H
*
CALL CGEMM( '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 CTRMM( '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 CGEMM( '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 CTRMM( '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 ) - CONJG( 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 CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
CALL CGEMM( '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 CTRMM( '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 CGEMM( '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 CTRMM( '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 CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ),
$ 1 )
CALL CLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( '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 CGEMM( '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 CTRMM( '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 CGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, N, K, -ONE, V,
$ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL CTRMM( '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 ) -
$ CONJG( 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 CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL CTRMM( '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 CGEMM( '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 CTRMM( '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 CGEMM( 'No transpose', 'No transpose', M, N-K,
$ K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL CTRMM( '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 CLARFB
*
END
*> \brief \b CLARFG generates an elementary reflector (Householder matrix).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX ALPHA, TAU
* ..
* .. Array Arguments ..
* COMPLEX X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFG 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
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX 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
*> 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 CLARFG( 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 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
REAL SCNRM2, SLAMCH, SLAPY3
COMPLEX CLADIV
EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN
* ..
* .. External Subroutines ..
EXTERNAL CSCAL, CSSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = SCNRM2( N-1, X, INCX )
ALPHR = REAL( ALPHA )
ALPHI = AIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = SLAMCH( 'S' ) / SLAMCH( '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 CSSCAL( 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 = SCNRM2( N-1, X, INCX )
ALPHA = CMPLX( ALPHR, ALPHI )
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
CALL CSCAL( 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 CLARFG
*
END
*> \brief \b CLARFT 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 CLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* COMPLEX T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLARFT 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 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 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX 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 CLARFT( 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 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* .. Parameters ..
*
COMPLEX ONE, NEG_ONE, ZERO
PARAMETER(ONE=1.0E+0, ZERO = 0.0E+0, NEG_ONE=-1.0E+0)
*
* .. Local Scalars ..
*
INTEGER I,J,L
LOGICAL QR,LQ,QL,DIRF,COLV
*
* .. External Subroutines ..
*
EXTERNAL CTRMM,CGEMM,CLACPY
*
* .. 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 CLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL CLARFT(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 CTRMM('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 CGEMM('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 CTRMM('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 CTRMM('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 CLARFT(DIRECT, STOREV, N, L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL CLARFT(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 CLACPY('All', L, K-L, V(1, L+1), LDV, T(1, L+1), LDT)
*
* T_{1,2} = T_{1,2}*V_{2,2}'
*
CALL CTRMM('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 CGEMM('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 CTRMM('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 CTRMM('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 CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL CLARFT(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 CTRMM('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 CGEMM('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 CTRMM('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 CTRMM('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 CLARFT(DIRECT, STOREV, N-L, K-L, V, LDV, TAU, T, LDT)
*
* Compute T_{2,2} recursively
*
CALL CLARFT(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 CLACPY('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 CTRMM('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 CGEMM('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 CTRMM('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 CTRMM('Right', 'Lower', 'No tranpose', 'Non-unit', L,
$ K-L, ONE, T, LDT, T(K-L+1, 1), LDT)
END IF
END SUBROUTINE
*> \brief \b CLASCL 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 CLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TYPE
* INTEGER INFO, KL, KU, LDA, M, N
* REAL CFROM, CTO
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLASCL 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 CGBTRF 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 REAL
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*> CTO is REAL
*>
*> 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 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 CLASCL( 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
REAL CFROM, CTO
* ..
* .. Array Arguments ..
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, SISNAN
REAL SLAMCH
EXTERNAL LSAME, SLAMCH, SISNAN
* ..
* .. 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. SISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( SISNAN(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( 'CLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = SLAMCH( '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 CLASCL
*
END
*> \brief \b CLASET 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 CLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* COMPLEX ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLASET 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
*> All the offdiagonal array elements are set to ALPHA.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> All the diagonal array elements are set to BETA.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is COMPLEX 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 CLASET( 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 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX 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 CLASET
*
END
*> \brief \b CLASR 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 CLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, PIVOT, SIDE
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* REAL C( * ), S( * )
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLASR 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 REAL 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 REAL 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 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 CLASR( 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 ..
REAL C( * ), S( * )
COMPLEX A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL CTEMP, STEMP
COMPLEX 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( 'CLASR ', 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 CLASR
*
END
!> \brief \b CLASSQ updates a sum of squares represented in scaled form.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLASSQ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
! Definition:
! ===========
!
! SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ )
!
! .. Scalar Arguments ..
! INTEGER INCX, N
! REAL SCALE, SUMSQ
! ..
! .. Array Arguments ..
! COMPLEX X( * )
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> CLASSQ returns the values scale_out and sumsq_out such that
!>
!> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> The number of elements to be used from the vector x.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is COMPLEX array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER
!> The increment between successive values of the vector x.
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!>
!> \param[in,out] SCALE
!> \verbatim
!> SCALE is REAL
!> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares.
!> \endverbatim
!>
!> \param[in,out] SUMSQ
!> \verbatim
!> SUMSQ is REAL
!> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scale_out has been factored out.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!> Nick Papior, Technical University of Denmark, DK
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!
!> \ingroup lassq
!
! =====================================================================
subroutine CLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, &
only: wp=>sp, zero=>szero, one=>sone, &
sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
use LA_XISNAN
!
! -- 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
real(wp) :: scale, sumsq
! ..
! .. Array Arguments ..
complex(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, ymax, ymin
! ..
!
! Quick return if possible
!
if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scale = one
if( scale == zero ) then
scale = one
sumsq = zero
end if
if (n <= 0) then
return
end if
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(real(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ax = abs(aimag(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Put the existing sum of squares into one of the accumulators
!
if( sumsq > zero ) then
ax = scale*sqrt( sumsq )
if (ax > tbig) then
if (scale > one) then
scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then
if (notbig) then
if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else
amed = amed + scale * (scale * sumsq)
end if
end if
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig
end if
scale = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scale = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range or zero
!
scale = one
sumsq = amed
end if
return
end subroutine
*> \brief \b CLATRD 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 CLATRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* REAL E( * )
* COMPLEX A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CLATRD 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', CLATRD reduces the last NB rows and columns of a
*> matrix, of which the upper triangle is supplied;
*> if UPLO = 'L', CLATRD reduces the first NB rows and columns of a
*> matrix, of which the lower triangle is supplied.
*>
*> This is an auxiliary routine called by CHETRD.
*> \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 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 REAL 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 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 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 CLATRD( 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 ..
REAL E( * )
COMPLEX A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO, ONE, HALF
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
$ ONE = ( 1.0E+0, 0.0E+0 ),
$ HALF = ( 0.5E+0, 0.0E+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IW
COMPLEX ALPHA
* ..
* .. External Subroutines ..
EXTERNAL CAXPY, CGEMV, CHEMV, CLACGV, CLARFG,
$ CSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX CDOTC
EXTERNAL LSAME, CDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, REAL
* ..
* .. 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 ) = REAL( A( I, I ) )
CALL CLACGV( N-I, W( I, IW+1 ), LDW )
CALL CGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL CLACGV( N-I, W( I, IW+1 ), LDW )
CALL CLACGV( N-I, A( I, I+1 ), LDA )
CALL CGEMV( 'No transpose', I, N-I, -ONE, W( 1,
$ IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
CALL CLACGV( N-I, A( I, I+1 ), LDA )
A( I, I ) = REAL( 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 CLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = REAL( ALPHA )
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL CHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL CGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL CGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL CGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL CGEMV( '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 CSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*CDOTC( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL CAXPY( 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 ) = REAL( A( I, I ) )
CALL CLACGV( I-1, W( I, 1 ), LDW )
CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL CLACGV( I-1, W( I, 1 ), LDW )
CALL CLACGV( I-1, A( I, 1 ), LDA )
CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
CALL CLACGV( I-1, A( I, 1 ), LDA )
A( I, I ) = REAL( 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 CLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = REAL( ALPHA )
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL CHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL CGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1,
$ 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL CGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1,
$ 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL CSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*CDOTC( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL CAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ),
$ 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of CLATRD
*
END
*> \brief \b CSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSCAL(N,CA,CX,INCX)
*
* .. Scalar Arguments ..
* COMPLEX CA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSCAL scales a vector by a constant.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] CA
*> \verbatim
*> CA is COMPLEX
*> On entry, CA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup scal
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSCAL(N,CA,CX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX CA
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX CX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,NINCX
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
* ..
IF (N.LE.0 .OR. INCX.LE.0 .OR. CA.EQ.ONE) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DO I = 1,N
CX(I) = CA*CX(I)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
CX(I) = CA*CX(I)
END DO
END IF
RETURN
*
* End of CSCAL
*
END
*> \brief \b CSROT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S )
*
* .. Scalar Arguments ..
* INTEGER INCX, INCY, N
* REAL C, S
* ..
* .. Array Arguments ..
* COMPLEX CX( * ), CY( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSROT applies a plane rotation, where the cos and sin (c and s) are real
*> and the vectors cx and cy are complex.
*> jack dongarra, linpack, 3/11/78.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the vectors cx and cy.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCX ) ).
*> Before entry, the incremented array CX must contain the n
*> element vector cx. On exit, CX is overwritten by the updated
*> vector cx.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> CX. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX array, dimension at least
*> ( 1 + ( N - 1 )*abs( INCY ) ).
*> Before entry, the incremented array CY must contain the n
*> element vector cy. On exit, CY is overwritten by the updated
*> vector cy.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> CY. INCY must not be zero.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> On entry, C specifies the cosine, cos.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is REAL
*> On entry, S specifies the sine, sin.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup rot
*
* =====================================================================
SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S )
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
REAL C, S
* ..
* .. Array Arguments ..
COMPLEX CX( * ), CY( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY
COMPLEX CTEMP
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN
*
* code for both increments equal to 1
*
DO I = 1, N
CTEMP = C*CX( I ) + S*CY( I )
CY( I ) = C*CY( I ) - S*CX( I )
CX( I ) = CTEMP
END DO
ELSE
*
* 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 I = 1, N
CTEMP = C*CX( IX ) + S*CY( IY )
CY( IY ) = C*CY( IY ) - S*CX( IX )
CX( IX ) = CTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of CSROT
*
END
*> \brief \b CSSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSSCAL(N,SA,CX,INCX)
*
* .. Scalar Arguments ..
* REAL SA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSSCAL scales a complex vector by a real constant.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is REAL
*> On entry, SA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup scal
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSSCAL(N,SA,CX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL SA
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX CX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,NINCX
* ..
* .. Parameters ..
REAL ONE
PARAMETER (ONE=1.0E+0)
* ..
* .. Intrinsic Functions ..
INTRINSIC AIMAG,CMPLX,REAL
* ..
IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DO I = 1,N
CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
END DO
END IF
RETURN
*
* End of CSSCAL
*
END
*> \brief \b CSTEDC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSTEDC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSTEDC( 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( * )
* REAL D( * ), E( * ), RWORK( * )
* COMPLEX WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSTEDC 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 CHETRD or CHPTRD or CHBTRD 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 REAL 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 REAL 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 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 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 REAL 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 CSTEDC( 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( * )
REAL D( * ), E( * ), RWORK( * )
COMPLEX WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
$ LRWMIN, LWMIN, M, SMLSIZ, START
REAL EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST, SROUNDUP_LWORK
EXTERNAL ILAENV, LSAME, SLAMCH, SLANST,
$ SROUNDUP_LWORK
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, CLACPY, CLACRM, CLAED0, CSTEQR,
$ CSWAP,
$ SLASCL, SLASET, SSTEDC, SSTEQR, SSTERF
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, 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, 'CSTEDC', ' ', 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( REAL( 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 ) = SROUNDUP_LWORK(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( 'CSTEDC', -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 SSTERF 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 SSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL SSTERF( 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 CSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
*
ELSE
*
* If COMPZ = 'I', we simply call SSTEDC instead.
*
IF( ICOMPZ.EQ.2 ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
LL = N*N + 1
CALL SSTEDC( '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 = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 70
*
EPS = SLAMCH( '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 = SLANST( 'M', M, D( START ), E( START ) )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ),
$ M,
$ INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1,
$ E( START ),
$ M-1, INFO )
*
CALL CLAED0( 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 SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ),
$ M,
$ INFO )
*
ELSE
CALL SSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
$ RWORK( M*M+1 ), INFO )
CALL CLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK,
$ N,
$ RWORK( M*M+1 ) )
CALL CLACPY( '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 CSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
60 CONTINUE
END IF
*
70 CONTINUE
WORK( 1 ) = SROUNDUP_LWORK(LWMIN)
RWORK( 1 ) = REAL( LRWMIN )
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of CSTEDC
*
END
*> \brief \b CSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CSTEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * ), WORK( * )
* COMPLEX Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSTEQR 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 CHETRD or CHPTRD or CHBTRD 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 REAL 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 REAL 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 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 REAL 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 CSTEQR( 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 ..
REAL D( * ), E( * ), WORK( * )
COMPLEX Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
COMPLEX CZERO, CONE
PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ),
$ CONE = ( 1.0E0, 0.0E0 ) )
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
REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL CLASET, CLASR, CSWAP, SLAE2, SLAEV2,
$ SLARTG,
$ SLASCL, SLASRT, XERBLA
* ..
* .. 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( 'CSTEQR', -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 = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( '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 CLASET( '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 = SLANST( '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 SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ),
$ N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ),
$ N,
$ INFO )
CALL SLASCL( '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 SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C,
$ S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL CLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 CLASR( '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 SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C,
$ S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL CLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 CLASR( '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 SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1,
$ E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( '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 SLASRT( '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 CSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
RETURN
*
* End of CSTEQR
*
END
*> \brief \b CSWAP
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSWAP(N,CX,INCX,CY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*),CY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSWAP interchanges two vectors.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of CY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup swap
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSWAP(N,CX,INCX,CY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
* ..
* .. Array Arguments ..
COMPLEX CX(*),CY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
COMPLEX CTEMP
INTEGER I,IX,IY
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
DO I = 1,N
CTEMP = CX(I)
CX(I) = CY(I)
CY(I) = CTEMP
END DO
ELSE
*
* 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 I = 1,N
CTEMP = CX(IX)
CX(IX) = CY(IY)
CY(IY) = CTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of CSWAP
*
END
*> \brief \b CTRMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRMM performs one of the matrix-matrix operations
*>
*> B := alpha*op( A )*B, or B := alpha*B*op( A )
*>
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) multiplies B from
*> the left or right as follows:
*>
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
*>
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A is an upper or
*> lower triangular matrix as follows:
*>
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
*>
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA specifies the form of op( A ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSA = 'N' or 'n' op( A ) = A.
*>
*> TRANSA = 'T' or 't' op( A ) = A**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG specifies whether or not A is unit triangular
*> as follows:
*>
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
*>
*> DIAG = 'N' or 'n' A is not assumed to be unit
*> triangular.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, k ), where k is m
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> upper triangular part of the array A must contain the upper
*> triangular matrix and the strictly lower triangular part of
*> A is not referenced.
*> Before entry with UPLO = 'L' or 'l', the leading k by k
*> lower triangular part of the array A must contain the lower
*> triangular matrix and the strictly upper triangular part of
*> A is not referenced.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced either, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When SIDE = 'L' or 'l' then
*> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, N ).
*> Before entry, the leading m by n part of the array B must
*> contain the matrix B, and on exit is overwritten by the
*> transformed matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trmm
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
LSIDE = LSAME(SIDE,'L')
IF (LSIDE) THEN
NROWA = M
ELSE
NROWA = N
END IF
NOCONJ = LSAME(TRANSA,'T')
NOUNIT = LSAME(DIAG,'N')
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ (.NOT.LSAME(TRANSA,'T')) .AND.
+ (.NOT.LSAME(TRANSA,'C'))) THEN
INFO = 3
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND.
+ (.NOT.LSAME(DIAG,'N'))) THEN
INFO = 4
ELSE IF (M.LT.0) THEN
INFO = 5
ELSE IF (N.LT.0) THEN
INFO = 6
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTRMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (M.EQ.0 .OR. N.EQ.0) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
B(I,J) = ZERO
10 CONTINUE
20 CONTINUE
RETURN
END IF
*
* Start the operations.
*
IF (LSIDE) THEN
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*A*B.
*
IF (UPPER) THEN
DO 50 J = 1,N
DO 40 K = 1,M
IF (B(K,J).NE.ZERO) THEN
TEMP = ALPHA*B(K,J)
DO 30 I = 1,K - 1
B(I,J) = B(I,J) + TEMP*A(I,K)
30 CONTINUE
IF (NOUNIT) TEMP = TEMP*A(K,K)
B(K,J) = TEMP
END IF
40 CONTINUE
50 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 K = M,1,-1
IF (B(K,J).NE.ZERO) THEN
TEMP = ALPHA*B(K,J)
B(K,J) = TEMP
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
DO 60 I = K + 1,M
B(I,J) = B(I,J) + TEMP*A(I,K)
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
END IF
ELSE
*
* Form B := alpha*A**T*B or B := alpha*A**H*B.
*
IF (UPPER) THEN
DO 120 J = 1,N
DO 110 I = M,1,-1
TEMP = B(I,J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 90 K = 1,I - 1
TEMP = TEMP + A(K,I)*B(K,J)
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
DO 100 K = 1,I - 1
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
100 CONTINUE
END IF
B(I,J) = ALPHA*TEMP
110 CONTINUE
120 CONTINUE
ELSE
DO 160 J = 1,N
DO 150 I = 1,M
TEMP = B(I,J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 130 K = I + 1,M
TEMP = TEMP + A(K,I)*B(K,J)
130 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
DO 140 K = I + 1,M
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
140 CONTINUE
END IF
B(I,J) = ALPHA*TEMP
150 CONTINUE
160 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*A.
*
IF (UPPER) THEN
DO 200 J = N,1,-1
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 170 I = 1,M
B(I,J) = TEMP*B(I,J)
170 CONTINUE
DO 190 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 180 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
180 CONTINUE
END IF
190 CONTINUE
200 CONTINUE
ELSE
DO 240 J = 1,N
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 210 I = 1,M
B(I,J) = TEMP*B(I,J)
210 CONTINUE
DO 230 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 220 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
220 CONTINUE
END IF
230 CONTINUE
240 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*A**T or B := alpha*B*A**H.
*
IF (UPPER) THEN
DO 280 K = 1,N
DO 260 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = ALPHA*A(J,K)
ELSE
TEMP = ALPHA*CONJG(A(J,K))
END IF
DO 250 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
250 CONTINUE
END IF
260 CONTINUE
TEMP = ALPHA
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = TEMP*A(K,K)
ELSE
TEMP = TEMP*CONJG(A(K,K))
END IF
END IF
IF (TEMP.NE.ONE) THEN
DO 270 I = 1,M
B(I,K) = TEMP*B(I,K)
270 CONTINUE
END IF
280 CONTINUE
ELSE
DO 320 K = N,1,-1
DO 300 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = ALPHA*A(J,K)
ELSE
TEMP = ALPHA*CONJG(A(J,K))
END IF
DO 290 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
290 CONTINUE
END IF
300 CONTINUE
TEMP = ALPHA
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = TEMP*A(K,K)
ELSE
TEMP = TEMP*CONJG(A(K,K))
END IF
END IF
IF (TEMP.NE.ONE) THEN
DO 310 I = 1,M
B(I,K) = TEMP*B(I,K)
310 CONTINUE
END IF
320 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTRMM
*
END
*> \brief \b CUNM2L 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 CUNM2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNM2L( 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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNM2L 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 CGEQLF. 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 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
*> CGEQLF 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 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by CGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CUNM2L( 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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CLARF1L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, 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( 'CUNM2L', -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 = CONJG( TAU( I ) )
END IF
CALL CLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC,
$ WORK )
10 CONTINUE
RETURN
*
* End of CUNM2L
*
END
*> \brief \b CUNM2R 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 CUNM2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNM2R( 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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNM2R 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 CGEQRF. 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 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
*> CGEQRF 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 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by CGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CUNM2R( 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 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL CLARF1F, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG, 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( 'CUNM2R', -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 = CONJG( TAU( I ) )
END IF
CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ),
$ LDC, WORK )
10 CONTINUE
RETURN
*
* End of CUNM2R
*
END
*> \brief \b CUNMQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNMQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNMQL( 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 A( LDA, * ), C( LDC, * ), TAU( * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNMQL 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 CGEQLF. 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 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
*> CGEQLF 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 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by CGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CUNMQL( 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 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
REAL SROUNDUP_LWORK
EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK
* ..
* .. External Subroutines ..
EXTERNAL CLARFB, CLARFT, CUNM2L, XERBLA
* ..
* .. 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, 'CUNMQL', SIDE // TRANS, M,
$ N,
$ K, -1 ) )
LWKOPT = NW*NB + TSIZE
END IF
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CUNMQL', -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
*
* Determine the block size
*
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, 'CUNMQL', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL CUNM2L( 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 CLARFT( '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 CLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI,
$ NI,
$ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
RETURN
*
* End of CUNMQL
*
END
*> \brief \b CUNMQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNMQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNMQR( 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 A( LDA, * ), C( LDC, * ), TAU( * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNMQR 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 CGEQRF. 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 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
*> CGEQRF 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 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by CGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CUNMQR( 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 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
REAL SROUNDUP_LWORK
EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK
* ..
* .. External Subroutines ..
EXTERNAL CLARFB, CLARFT, CUNM2R, XERBLA
* ..
* .. 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, 'CUNMQR', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
LWKOPT = NW*NB + TSIZE
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CUNMQR', -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, 'CUNMQR', SIDE // TRANS, M, N,
$ K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL CUNM2R( 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 CLARFT( '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 CLARFB( 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 ) = SROUNDUP_LWORK(LWKOPT)
RETURN
*
* End of CUNMQR
*
END
*> \brief \b CUNMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNMTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE CUNMTR( 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 A( LDA, * ), C( LDC, * ), TAU( * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CUNMTR 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 CHETRD:
*>
*> 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 CHETRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from CHETRD.
*> \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 array, dimension
*> (LDA,M) if SIDE = 'L'
*> (LDA,N) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by CHETRD.
*> \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 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 CHETRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX 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 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 CUNMTR( 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 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
REAL SROUNDUP_LWORK
EXTERNAL ILAENV, LSAME, SROUNDUP_LWORK
* ..
* .. External Subroutines ..
EXTERNAL CUNMQL, CUNMQR, XERBLA
* ..
* .. 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, 'CUNMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'CUNMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = NW*NB
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'CUNMTR', -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 CHETRD with UPLO = 'U'
*
CALL CUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU,
$ C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to CHETRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL CUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = SROUNDUP_LWORK(LWKOPT)
RETURN
*
* End of CUNMTR
*
END
*> \brief \b IEEECK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IEEECK + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* .. Scalar Arguments ..
* INTEGER ISPEC
* REAL ONE, ZERO
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IEEECK is called from the ILAENV to verify that Infinity and
*> possibly NaN arithmetic is safe (i.e. will not trap).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ISPEC
*> \verbatim
*> ISPEC is INTEGER
*> Specifies whether to test just for infinity arithmetic
*> or whether to test for infinity and NaN arithmetic.
*> = 0: Verify infinity arithmetic only.
*> = 1: Verify infinity and NaN arithmetic.
*> \endverbatim
*>
*> \param[in] ZERO
*> \verbatim
*> ZERO is REAL
*> Must contain the value 0.0
*> This is passed to prevent the compiler from optimizing
*> away this code.
*> \endverbatim
*>
*> \param[in] ONE
*> \verbatim
*> ONE is REAL
*> Must contain the value 1.0
*> This is passed to prevent the compiler from optimizing
*> away this code.
*>
*> RETURN VALUE: INTEGER
*> = 0: Arithmetic failed to produce the correct answers
*> = 1: Arithmetic produced the correct answers
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ieeeck
*
* =====================================================================
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* -- 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 ISPEC
REAL ONE, ZERO
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
$ NEGZRO, NEWZRO, POSINF
* ..
* .. Executable Statements ..
IEEECK = 1
*
POSINF = ONE / ZERO
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = -ONE / ZERO
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEGZRO = ONE / ( NEGINF+ONE )
IF( NEGZRO.NE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = ONE / NEGZRO
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
NEWZRO = NEGZRO + ZERO
IF( NEWZRO.NE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
POSINF = ONE / NEWZRO
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
NEGINF = NEGINF*POSINF
IF( NEGINF.GE.ZERO ) THEN
IEEECK = 0
RETURN
END IF
*
POSINF = POSINF*POSINF
IF( POSINF.LE.ONE ) THEN
IEEECK = 0
RETURN
END IF
*
*
*
*
* Return if we were only asked to check infinity arithmetic
*
IF( ISPEC.EQ.0 )
$ RETURN
*
NAN1 = POSINF + NEGINF
*
NAN2 = POSINF / NEGINF
*
NAN3 = POSINF / POSINF
*
NAN4 = POSINF*ZERO
*
NAN5 = NEGINF*NEGZRO
*
NAN6 = NAN5*ZERO
*
IF( NAN1.EQ.NAN1 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN2.EQ.NAN2 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN3.EQ.NAN3 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN4.EQ.NAN4 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN5.EQ.NAN5 ) THEN
IEEECK = 0
RETURN
END IF
*
IF( NAN6.EQ.NAN6 ) THEN
IEEECK = 0
RETURN
END IF
*
RETURN
END
*> \brief \b ILACLC scans a matrix for its last non-zero column.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILACLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILACLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILACLC 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 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 ILACLC( 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 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILACLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILACLC = N, 1, -1
DO I = 1, M
IF( A(I, ILACLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
*> \brief \b ILACLR scans a matrix for its last non-zero row.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILACLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILACLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILACLR 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 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 ILACLR( 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 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+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
ILACLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILACLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILACLR = MAX( ILACLR, I )
END DO
END IF
RETURN
END
*> \brief \b ILAENV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAENV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
* .. Scalar Arguments ..
* CHARACTER*( * ) NAME, OPTS
* INTEGER ISPEC, N1, N2, N3, N4
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAENV is called from the LAPACK routines to choose problem-dependent
*> parameters for the local environment. See ISPEC for a description of
*> the parameters.
*>
*> ILAENV returns an INTEGER
*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
*>
*> This version provides a set of parameters which should give good,
*> but not optimal, performance on many of the currently available
*> computers. Users are encouraged to modify this subroutine to set
*> the tuning parameters for their particular machine using the option
*> and problem size information in the arguments.
*>
*> This routine will not function correctly if it is converted to all
*> lower case. Converting it to all upper case is allowed.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ISPEC
*> \verbatim
*> ISPEC is INTEGER
*> Specifies the parameter to be returned as the value of
*> ILAENV.
*> = 1: the optimal blocksize; if this value is 1, an unblocked
*> algorithm will give the best performance.
*> = 2: the minimum block size for which the block routine
*> should be used; if the usable block size is less than
*> this value, an unblocked routine should be used.
*> = 3: the crossover point (in a block routine, for N less
*> than this value, an unblocked routine should be used)
*> = 4: the number of shifts, used in the nonsymmetric
*> eigenvalue routines (DEPRECATED)
*> = 5: the minimum column dimension for blocking to be used;
*> rectangular blocks must have dimension at least k by m,
*> where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*> = 6: the crossover point for the SVD (when reducing an m by n
*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*> this value, a QR factorization is used first to reduce
*> the matrix to a triangular form.)
*> = 7: the number of processors
*> = 8: the crossover point for the multishift QR method
*> for nonsymmetric eigenvalue problems (DEPRECATED)
*> = 9: maximum size of the subproblems at the bottom of the
*> computation tree in the divide-and-conquer algorithm
*> (used by xGELSD and xGESDD)
*> =10: ieee infinity and NaN arithmetic can be trusted not to trap
*> =11: infinity arithmetic can be trusted not to trap
*> 12 <= ISPEC <= 17:
*> xHSEQR or related subroutines,
*> see IPARMQ for detailed explanation
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*> NAME is CHARACTER*(*)
*> The name of the calling subroutine, in either upper case or
*> lower case.
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*> OPTS is CHARACTER*(*)
*> The character options to the subroutine NAME, concatenated
*> into a single character string. For example, UPLO = 'U',
*> TRANS = 'T', and DIAG = 'N' for a triangular routine would
*> be specified as OPTS = 'UTN'.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*> N1 is INTEGER
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*> N2 is INTEGER
*> \endverbatim
*>
*> \param[in] N3
*> \verbatim
*> N3 is INTEGER
*> \endverbatim
*>
*> \param[in] N4
*> \verbatim
*> N4 is INTEGER
*> Problem dimensions for the subroutine NAME; these may not all
*> be required.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ilaenv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The following conventions have been used when calling ILAENV from the
*> LAPACK routines:
*> 1) OPTS is a concatenation of all of the character options to
*> subroutine NAME, in the same order that they appear in the
*> argument list for NAME, even if they are not used in determining
*> the value of the parameter specified by ISPEC.
*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order
*> that they appear in the argument list for NAME. N1 is used
*> first, N2 second, and so on, and unused problem dimensions are
*> passed a value of -1.
*> 3) The parameter value returned by ILAENV is checked for validity in
*> the calling subroutine. For example, ILAENV is used to retrieve
*> the optimal blocksize for STRTRI as follows:
*>
*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*> IF( NB.LE.1 ) NB = MAX( 1, N )
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
*
* -- 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*( * ) NAME, OPTS
INTEGER ISPEC, N1, N2, N3, N4
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IC, IZ, NB, NBMIN, NX
LOGICAL CNAME, SNAME, TWOSTAGE
CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16
* ..
* .. Intrinsic Functions ..
INTRINSIC CHAR, ICHAR, INT, MIN, REAL
* ..
* .. External Functions ..
INTEGER IEEECK, IPARMQ, IPARAM2STAGE
EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE
* ..
* .. Executable Statements ..
*
GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
$ 130, 140, 150, 160, 160, 160, 160, 160, 160)ISPEC
*
* Invalid value for ISPEC
*
ILAENV = -1
RETURN
*
10 CONTINUE
*
* Convert NAME to upper case if the first character is lower case.
*
ILAENV = 1
SUBNAM = NAME
IC = ICHAR( SUBNAM( 1: 1 ) )
IZ = ICHAR( 'Z' )
IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
* ASCII character set
*
IF( IC.GE.97 .AND. IC.LE.122 ) THEN
SUBNAM( 1: 1 ) = CHAR( IC-32 )
DO 20 I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
20 CONTINUE
END IF
*
ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
* EBCDIC character set
*
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
SUBNAM( 1: 1 ) = CHAR( IC+64 )
DO 30 I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
$ I ) = CHAR( IC+64 )
30 CONTINUE
END IF
*
ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
* Prime machines: ASCII+128
*
IF( IC.GE.225 .AND. IC.LE.250 ) THEN
SUBNAM( 1: 1 ) = CHAR( IC-32 )
DO 40 I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
40 CONTINUE
END IF
END IF
*
C1 = SUBNAM( 1: 1 )
SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
IF( .NOT.( CNAME .OR. SNAME ) )
$ RETURN
C2 = SUBNAM( 2: 3 )
C3 = SUBNAM( 4: 6 )
C4 = C3( 2: 3 )
TWOSTAGE = LEN( SUBNAM ).GE.11
$ .AND. SUBNAM( 11: 11 ).EQ.'2'
*
GO TO ( 50, 60, 70 )ISPEC
*
50 CONTINUE
*
* ISPEC = 1: block size
*
* In these examples, separate code is provided for setting NB for
* real and complex. We assume that NB will take the same value in
* single or double precision.
*
NB = 1
*
IF( SUBNAM(2:6).EQ.'LAORH' ) THEN
*
* This is for *LAORHR_GETRFNP routine
*
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
$ C3.EQ.'QLF' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'QR ') THEN
IF( N3 .EQ. 1) THEN
IF( SNAME ) THEN
* M*N
IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN
NB = N1
ELSE
NB = 32768/N2
END IF
ELSE
IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN
NB = N1
ELSE
NB = 32768/N2
END IF
END IF
ELSE
IF( SNAME ) THEN
NB = 1
ELSE
NB = 1
END IF
END IF
ELSE IF( C3.EQ.'LQ ') THEN
IF( N3 .EQ. 2) THEN
IF( SNAME ) THEN
* M*N
IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN
NB = N1
ELSE
NB = 32768/N2
END IF
ELSE
IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN
NB = N1
ELSE
NB = 32768/N2
END IF
END IF
ELSE
IF( SNAME ) THEN
NB = 1
ELSE
NB = 1
END IF
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
ELSE IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
END IF
ELSE IF( C2.EQ.'PO' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
IF( TWOSTAGE ) THEN
NB = 192
ELSE
NB = 64
END IF
ELSE
IF( TWOSTAGE ) THEN
NB = 192
ELSE
NB = 64
END IF
END IF
ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NB = 32
ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
NB = 64
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( TWOSTAGE ) THEN
NB = 192
ELSE
NB = 64
END IF
ELSE IF( C3.EQ.'TRD' ) THEN
NB = 32
ELSE IF( C3.EQ.'GST' ) THEN
NB = 64
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NB = 32
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NB = 32
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NB = 32
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NB = 32
END IF
END IF
ELSE IF( C2.EQ.'GB' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
IF( N4.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
ELSE
IF( N4.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
END IF
END IF
ELSE IF( C2.EQ.'PB' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
IF( N2.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
ELSE
IF( N2.LE.64 ) THEN
NB = 1
ELSE
NB = 32
END IF
END IF
END IF
ELSE IF( C2.EQ.'TR' ) THEN
IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF ( C3.EQ.'EVC' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( C3.EQ.'SYL' ) THEN
* The upper bound is to prevent overly aggressive scaling.
IF( SNAME ) THEN
NB = MIN( MAX( 48, INT( ( MIN( N1, N2 ) * 16 ) / 100) ),
$ 240 )
ELSE
NB = MIN( MAX( 24, INT( ( MIN( N1, N2 ) * 8 ) / 100) ),
$ 80 )
END IF
END IF
ELSE IF( C2.EQ.'LA' ) THEN
IF( C3.EQ.'UUM' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
END IF
ELSE IF( C3.EQ.'TRS' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
END IF
ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
IF( C3.EQ.'EBZ' ) THEN
NB = 1
END IF
ELSE IF( C2.EQ.'GG' ) THEN
NB = 32
IF( C3.EQ.'HD3' ) THEN
IF( SNAME ) THEN
NB = 32
ELSE
NB = 32
END IF
END IF
END IF
ILAENV = NB
RETURN
*
60 CONTINUE
*
* ISPEC = 2: minimum block size
*
NBMIN = 2
IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
$ 'QLF' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( C3.EQ.'TRI' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
IF( SNAME ) THEN
NBMIN = 2
ELSE
NBMIN = 2
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( C3.EQ.'TRF' ) THEN
IF( SNAME ) THEN
NBMIN = 8
ELSE
NBMIN = 8
END IF
ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NBMIN = 2
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NBMIN = 2
END IF
END IF
ELSE IF( C2.EQ.'GG' ) THEN
NBMIN = 2
IF( C3.EQ.'HD3' ) THEN
NBMIN = 2
END IF
END IF
ILAENV = NBMIN
RETURN
*
70 CONTINUE
*
* ISPEC = 3: crossover point
*
NX = 0
IF( C2.EQ.'GE' ) THEN
IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
$ 'QLF' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
ELSE IF( C3.EQ.'HRD' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
ELSE IF( C3.EQ.'BRD' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN
IF( SNAME ) THEN
NX = 128
ELSE
NX = 128
END IF
END IF
ELSE IF( C2.EQ.'SY' ) THEN
IF( SNAME .AND. C3.EQ.'TRD' ) THEN
NX = 32
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NX = 32
END IF
ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NX = 128
END IF
END IF
ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
IF( C3( 1: 1 ).EQ.'G' ) THEN
IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
$ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
$ THEN
NX = 128
END IF
END IF
ELSE IF( C2.EQ.'GG' ) THEN
NX = 128
IF( C3.EQ.'HD3' ) THEN
NX = 128
END IF
END IF
ILAENV = NX
RETURN
*
80 CONTINUE
*
* ISPEC = 4: number of shifts (used by xHSEQR)
*
ILAENV = 6
RETURN
*
90 CONTINUE
*
* ISPEC = 5: minimum column dimension (not used)
*
ILAENV = 2
RETURN
*
100 CONTINUE
*
* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
RETURN
*
110 CONTINUE
*
* ISPEC = 7: number of processors (not used)
*
ILAENV = 1
RETURN
*
120 CONTINUE
*
* ISPEC = 8: crossover point for multishift (used by xHSEQR)
*
ILAENV = 50
RETURN
*
130 CONTINUE
*
* ISPEC = 9: maximum size of the subproblems at the bottom of the
* computation tree in the divide-and-conquer algorithm
* (used by xGELSD and xGESDD)
*
ILAENV = 25
RETURN
*
140 CONTINUE
*
* ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap
*
* ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 1, 0.0, 1.0 )
END IF
RETURN
*
150 CONTINUE
*
* ISPEC = 11: ieee infinity arithmetic can be trusted not to trap
*
* ILAENV = 0
ILAENV = 1
IF( ILAENV.EQ.1 ) THEN
ILAENV = IEEECK( 0, 0.0, 1.0 )
END IF
RETURN
*
160 CONTINUE
*
* 12 <= ISPEC <= 17: xHSEQR or related subroutines.
*
ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
RETURN
*
* End of ILAENV
*
END
*> \brief \b IPARMQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IPARMQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, ISPEC, LWORK, N
* CHARACTER NAME*( * ), OPTS*( * )
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This program sets problem and machine dependent parameters
*> useful for xHSEQR and related subroutines for eigenvalue
*> problems. It is called whenever
*> IPARMQ is called with 12 <= ISPEC <= 16
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ISPEC
*> \verbatim
*> ISPEC is INTEGER
*> ISPEC specifies which tunable parameter IPARMQ should
*> return.
*>
*> ISPEC=12: (INMIN) Matrices of order nmin or less
*> are sent directly to xLAHQR, the implicit
*> double shift QR algorithm. NMIN must be
*> at least 11.
*>
*> ISPEC=13: (INWIN) Size of the deflation window.
*> This is best set greater than or equal to
*> the number of simultaneous shifts NS.
*> Larger matrices benefit from larger deflation
*> windows.
*>
*> ISPEC=14: (INIBL) Determines when to stop nibbling and
*> invest in an (expensive) multi-shift QR sweep.
*> If the aggressive early deflation subroutine
*> finds LD converged eigenvalues from an order
*> NW deflation window and LD > (NW*NIBBLE)/100,
*> then the next QR sweep is skipped and early
*> deflation is applied immediately to the
*> remaining active diagonal block. Setting
*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
*> multi-shift QR sweep whenever early deflation
*> finds a converged eigenvalue. Setting
*> IPARMQ(ISPEC=14) greater than or equal to 100
*> prevents TTQRE from skipping a multi-shift
*> QR sweep.
*>
*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in
*> a multi-shift QR iteration.
*>
*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
*> following meanings.
*> 0: During the multi-shift QR/QZ sweep,
*> blocked eigenvalue reordering, blocked
*> Hessenberg-triangular reduction,
*> reflections and/or rotations are not
*> accumulated when updating the
*> far-from-diagonal matrix entries.
*> 1: During the multi-shift QR/QZ sweep,
*> blocked eigenvalue reordering, blocked
*> Hessenberg-triangular reduction,
*> reflections and/or rotations are
*> accumulated, and matrix-matrix
*> multiplication is used to update the
*> far-from-diagonal matrix entries.
*> 2: During the multi-shift QR/QZ sweep,
*> blocked eigenvalue reordering, blocked
*> Hessenberg-triangular reduction,
*> reflections and/or rotations are
*> accumulated, and 2-by-2 block structure
*> is exploited during matrix-matrix
*> multiplies.
*> (If xTRMM is slower than xGEMM, then
*> IPARMQ(ISPEC=16)=1 may be more efficient than
*> IPARMQ(ISPEC=16)=2 despite the greater level of
*> arithmetic work implied by the latter choice.)
*>
*> ISPEC=17: (ICOST) An estimate of the relative cost of flops
*> within the near-the-diagonal shift chase compared
*> to flops within the BLAS calls of a QZ sweep.
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*> NAME is CHARACTER string
*> Name of the calling subroutine
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*> OPTS is CHARACTER string
*> This is a concatenation of the string arguments to
*> TTQRE.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> N is the order of the Hessenberg matrix H.
*> \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.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The amount of workspace available.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup iparmq
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Little is known about how best to choose these parameters.
*> It is possible to use different values of the parameters
*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
*>
*> It is probably best to choose different parameters for
*> different matrices and different parameters at different
*> times during the iteration, but this has not been
*> implemented --- yet.
*>
*>
*> The best choices of most of the parameters depend
*> in an ill-understood way on the relative execution
*> rate of xLAQR3 and xLAQR5 and on the nature of each
*> particular eigenvalue problem. Experiment may be the
*> only practical way to determine which choices are most
*> effective.
*>
*> Following is a list of default values supplied by IPARMQ.
*> These defaults may be adjusted in order to attain better
*> performance in any particular computational environment.
*>
*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
*> Default: 75. (Must be at least 11.)
*>
*> IPARMQ(ISPEC=13) Recommended deflation window size.
*> This depends on ILO, IHI and NS, the
*> number of simultaneous shifts returned
*> by IPARMQ(ISPEC=15). The default for
*> (IHI-ILO+1) <= 500 is NS. The default
*> for (IHI-ILO+1) > 500 is 3*NS/2.
*>
*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
*>
*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
*> a multi-shift QR iteration.
*>
*> If IHI-ILO+1 is ...
*>
*> greater than ...but less ... the
*> or equal to ... than default is
*>
*> 0 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 matrices of this order are
*> passed to the implicit double shift routine
*> xLAHQR. See IPARMQ(ISPEC=12) above. These
*> values of NS are used only in case of a rare
*> xLAHQR failure.
*>
*> (**) The asterisks (**) indicate an ad-hoc
*> function increasing from 10 to 64.
*>
*> IPARMQ(ISPEC=16) Select structured matrix multiply.
*> (See ISPEC=16 above for details.)
*> Default: 3.
*>
*> IPARMQ(ISPEC=17) Relative cost heuristic for blocksize selection.
*> Expressed as a percentage.
*> Default: 10.
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI,
$ 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 IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
*
* ================================================================
* .. Parameters ..
INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22, ICOST
PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
$ ISHFTS = 15, IACC22 = 16, ICOST = 17 )
INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP, RCOST
PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14,
$ NIBBLE = 14, KNWSWP = 500, RCOST = 10 )
REAL TWO
PARAMETER ( TWO = 2.0 )
* ..
* .. Local Scalars ..
INTEGER NH, NS
INTEGER I, IC, IZ
CHARACTER SUBNAM*6
* ..
* .. Intrinsic Functions ..
INTRINSIC LOG, MAX, MOD, NINT, REAL
* ..
* .. Executable Statements ..
IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
$ ( ISPEC.EQ.IACC22 ) ) THEN
*
* ==== Set the number simultaneous shifts ====
*
NH = IHI - ILO + 1
NS = 2
IF( NH.GE.30 )
$ NS = 4
IF( NH.GE.60 )
$ NS = 10
IF( NH.GE.150 )
$ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
IF( NH.GE.590 )
$ NS = 64
IF( NH.GE.3000 )
$ NS = 128
IF( NH.GE.6000 )
$ NS = 256
NS = MAX( 2, NS-MOD( NS, 2 ) )
END IF
*
IF( ISPEC.EQ.INMIN ) THEN
*
*
* ===== Matrices of order smaller than NMIN get sent
* . to xLAHQR, the classic double shift algorithm.
* . This must be at least 11. ====
*
IPARMQ = NMIN
*
ELSE IF( ISPEC.EQ.INIBL ) THEN
*
* ==== INIBL: skip a multi-shift qr iteration and
* . whenever aggressive early deflation finds
* . at least (NIBBLE*(window size)/100) deflations. ====
*
IPARMQ = NIBBLE
*
ELSE IF( ISPEC.EQ.ISHFTS ) THEN
*
* ==== NSHFTS: The number of simultaneous shifts =====
*
IPARMQ = NS
*
ELSE IF( ISPEC.EQ.INWIN ) THEN
*
* ==== NW: deflation window size. ====
*
IF( NH.LE.KNWSWP ) THEN
IPARMQ = NS
ELSE
IPARMQ = 3*NS / 2
END IF
*
ELSE IF( ISPEC.EQ.IACC22 ) THEN
*
* ==== IACC22: Whether to accumulate reflections
* . before updating the far-from-diagonal elements
* . and whether to use 2-by-2 block structure while
* . doing it. A small amount of work could be saved
* . by making this choice dependent also upon the
* . NH=IHI-ILO+1.
*
*
* Convert NAME to upper case if the first character is lower case.
*
IPARMQ = 0
SUBNAM = NAME
IC = ICHAR( SUBNAM( 1: 1 ) )
IZ = ICHAR( 'Z' )
IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
* ASCII character set
*
IF( IC.GE.97 .AND. IC.LE.122 ) THEN
SUBNAM( 1: 1 ) = CHAR( IC-32 )
DO I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
END DO
END IF
*
ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
* EBCDIC character set
*
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
SUBNAM( 1: 1 ) = CHAR( IC+64 )
DO I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
$ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
$ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
$ I ) = CHAR( IC+64 )
END DO
END IF
*
ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
* Prime machines: ASCII+128
*
IF( IC.GE.225 .AND. IC.LE.250 ) THEN
SUBNAM( 1: 1 ) = CHAR( IC-32 )
DO I = 2, 6
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
END DO
END IF
END IF
*
IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR.
$ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN
IPARMQ = 1
IF( NH.GE.K22MIN )
$ IPARMQ = 2
ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN
IF( NH.GE.KACMIN )
$ IPARMQ = 1
IF( NH.GE.K22MIN )
$ IPARMQ = 2
ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR.
$ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN
IF( NS.GE.KACMIN )
$ IPARMQ = 1
IF( NS.GE.K22MIN )
$ IPARMQ = 2
END IF
*
ELSE IF( ISPEC.EQ.ICOST ) THEN
*
* === Relative cost of near-the-diagonal chase vs
* BLAS updates ===
*
IPARMQ = RCOST
ELSE
* ===== invalid value of ispec =====
IPARMQ = -1
*
END IF
*
* ==== End of IPARMQ ====
*
END
*> \brief \b ISAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION ISAMAX(N,SX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* REAL SX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ISAMAX finds the index of the first element having maximum absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup iamax
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION ISAMAX(N,SX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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 ..
REAL SX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL SMAX
INTEGER I,IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
ISAMAX = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
ISAMAX = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
SMAX = ABS(SX(1))
DO I = 2,N
IF (ABS(SX(I)).GT.SMAX) THEN
ISAMAX = I
SMAX = ABS(SX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
SMAX = ABS(SX(1))
IX = IX + INCX
DO I = 2,N
IF (ABS(SX(IX)).GT.SMAX) THEN
ISAMAX = I
SMAX = ABS(SX(IX))
END IF
IX = IX + INCX
END DO
END IF
RETURN
*
* End of ISAMAX
*
END
*> \brief \b LSAME
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* LOGICAL FUNCTION LSAME(CA,CB)
*
* .. Scalar Arguments ..
* CHARACTER CA,CB
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
*> case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CA
*> \verbatim
*> CA is CHARACTER*1
*> \endverbatim
*>
*> \param[in] CB
*> \verbatim
*> CB is CHARACTER*1
*> CA and CB specify the single characters to be compared.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lsame
*
* =====================================================================
LOGICAL FUNCTION LSAME(CA,CB)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER CA,CB
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* ..
* .. Local Scalars ..
INTEGER INTA,INTB,ZCODE
* ..
*
* Test if the characters are equal
*
LSAME = CA .EQ. CB
IF (LSAME) RETURN
*
* Now test for equivalence if both characters are alphabetic.
*
ZCODE = ICHAR('Z')
*
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
* machines, on which ICHAR returns a value with bit 8 set.
* ICHAR('A') on Prime machines returns 193 which is the same as
* ICHAR('A') on an EBCDIC machine.
*
INTA = ICHAR(CA)
INTB = ICHAR(CB)
*
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
*
* ASCII is assumed - ZCODE is the ASCII code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
*
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
*
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
*
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
*
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
* plus 128 of either lower or upper case 'Z'.
*
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
END IF
LSAME = INTA .EQ. INTB
*
* RETURN
*
* End of LSAME
*
END
*> \brief \b SCABS1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SCABS1(Z)
*
* .. Scalar Arguments ..
* COMPLEX Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCABS1 computes |Re(.)| + |Im(.)| of a complex number
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] Z
*> \verbatim
*> Z is COMPLEX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup abs1
*
* =====================================================================
REAL FUNCTION SCABS1(Z)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX Z
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ABS,AIMAG,REAL
* ..
SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z))
RETURN
*
* End of SCABS1
*
END
!> \brief \b SCNRM2
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! REAL FUNCTION SCNRM2(N,X,INCX)
!
! .. Scalar Arguments ..
! INTEGER INCX,N
! ..
! .. Array Arguments ..
! COMPLEX X(*)
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> SCNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!> SCNRM2 := sqrt( x**H*x )
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is COMPLEX array, dimension (N)
!> complex vector with N elements
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER, storage spacing between elements of X
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup nrm2
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
! =====================================================================
function SCNRM2( n, x, incx )
integer, parameter :: wp = kind(1.e0)
real(wp) :: SCNRM2
!
! -- Reference BLAS level1 routine (version 3.9.1) --
! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! March 2021
!
! .. Constants ..
real(wp), parameter :: zero = 0.0_wp
real(wp), parameter :: one = 1.0_wp
real(wp), parameter :: maxN = huge(0.0_wp)
! ..
! .. Blue's scaling constants ..
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
(minexponent(0._wp) - 1) * 0.5_wp)
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp))
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp))
! ..
! .. Scalar Arguments ..
integer :: incx, n
! ..
! .. Array Arguments ..
complex(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
! Quick return if possible
!
SCNRM2 = zero
if( n <= 0 ) return
!
scl = one
sumsq = zero
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(real(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ax = abs(aimag(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range
!
scl = one
sumsq = amed
end if
SCNRM2 = scl*sqrt( sumsq )
return
end function
*> \brief \b SCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* REAL SX(*),SY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCOPY copies a vector, x, to a vector, y.
*> uses unrolled loops for increments equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*>
*> \param[out] SY
*> \verbatim
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of SY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup copy
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,7)
IF (M.NE.0) THEN
DO I = 1,M
SY(I) = SX(I)
END DO
IF (N.LT.7) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,7
SY(I) = SX(I)
SY(I+1) = SX(I+1)
SY(I+2) = SX(I+2)
SY(I+3) = SX(I+3)
SY(I+4) = SX(I+4)
SY(I+5) = SX(I+5)
SY(I+6) = SX(I+6)
END DO
ELSE
*
* 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 I = 1,N
SY(IY) = SX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of SCOPY
*
END
*> \brief \b SGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* REAL ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* REAL A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SGEMM performs one of the matrix-matrix operations
*>
*> C := alpha*op( A )*op( B ) + beta*C,
*>
*> where op( X ) is one of
*>
*> op( X ) = X or op( X ) = X**T,
*>
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA specifies the form of op( A ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSA = 'N' or 'n', op( A ) = A.
*>
*> TRANSA = 'T' or 't', op( A ) = A**T.
*>
*> TRANSA = 'C' or 'c', op( A ) = A**T.
*> \endverbatim
*>
*> \param[in] TRANSB
*> \verbatim
*> TRANSB is CHARACTER*1
*> On entry, TRANSB specifies the form of op( B ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSB = 'N' or 'n', op( B ) = B.
*>
*> TRANSB = 'T' or 't', op( B ) = B**T.
*>
*> TRANSB = 'C' or 'c', op( B ) = B**T.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix
*> op( A ) and of the matrix C. M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix
*> op( B ) and the number of columns of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry, K specifies the number of columns of the matrix
*> op( A ) and the number of rows of the matrix op( B ). K must
*> be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension ( LDA, ka ), where ka is
*> k when TRANSA = 'N' or 'n', and is m otherwise.
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
*> part of the array A must contain the matrix A, otherwise
*> the leading k by m part of the array A must contain the
*> matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
*> LDA must be at least max( 1, m ), otherwise LDA must be at
*> least max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is REAL array, dimension ( LDB, kb ), where kb is
*> n when TRANSB = 'N' or 'n', and is k otherwise.
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
*> part of the array B must contain the matrix B, otherwise
*> the leading n by k part of the array B must contain the
*> matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
*> LDB must be at least max( 1, k ), otherwise LDB must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then C need not be set on input.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is REAL array, dimension ( LDC, N )
*> Before entry, the leading m by n part of the array C must
*> contain the matrix C, except when beta is zero, in which
*> case C need not be set on entry.
*> On exit, the array C is overwritten by the m by n matrix
*> ( alpha*op( A )*op( B ) + beta*C ).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemm
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,
+ BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
REAL A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,J,L,NROWA,NROWB
LOGICAL NOTA,NOTB
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
*
* Set NOTA and NOTB as true if A and B respectively are not
* transposed and set NROWA and NROWB as the number of rows of A
* and B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
IF (NOTA) THEN
NROWA = M
ELSE
NROWA = K
END IF
IF (NOTB) THEN
NROWB = K
ELSE
NROWB = N
END IF
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+ (.NOT.LSAME(TRANSA,'T'))) THEN
INFO = 1
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+ (.NOT.LSAME(TRANSB,'T'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 8
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
INFO = 10
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SGEMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And if alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (NOTB) THEN
IF (NOTA) THEN
*
* Form C := alpha*A*B + beta*C.
*
DO 90 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 50 I = 1,M
C(I,J) = ZERO
50 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 60 I = 1,M
C(I,J) = BETA*C(I,J)
60 CONTINUE
END IF
DO 80 L = 1,K
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
80 CONTINUE
90 CONTINUE
ELSE
*
* Form C := alpha*A**T*B + beta*C
*
DO 120 J = 1,N
DO 110 I = 1,M
TEMP = ZERO
DO 100 L = 1,K
TEMP = TEMP + A(L,I)*B(L,J)
100 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
110 CONTINUE
120 CONTINUE
END IF
ELSE
IF (NOTA) THEN
*
* Form C := alpha*A*B**T + beta*C
*
DO 170 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 130 I = 1,M
C(I,J) = ZERO
130 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 140 I = 1,M
C(I,J) = BETA*C(I,J)
140 CONTINUE
END IF
DO 160 L = 1,K
TEMP = ALPHA*B(J,L)
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
150 CONTINUE
160 CONTINUE
170 CONTINUE
ELSE
*
* Form C := alpha*A**T*B**T + beta*C
*
DO 200 J = 1,N
DO 190 I = 1,M
TEMP = ZERO
DO 180 L = 1,K
TEMP = TEMP + A(L,I)*B(J,L)
180 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
190 CONTINUE
200 CONTINUE
END IF
END IF
*
RETURN
*
* End of SGEMM
*
END
*> \brief \b SGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* REAL ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* REAL A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SGEMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
*>
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients.
*> \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, m ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is REAL array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*> Before entry, the incremented array X must contain the
*> vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is REAL array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*> Before entry with BETA non-zero, the incremented array Y
*> must contain the vector y. On exit, Y is overwritten by the
*> updated vector y.
*> If either m or n is zero, then Y not referenced and the function
*> performs a quick return.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
REAL A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
* .. Local Scalars ..
REAL TEMP
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) 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 = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
ELSE IF (INCY.EQ.0) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('SGEMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set LENX and LENY, the lengths of the vectors x and y, and set
* up the start points in X and Y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
ELSE
LENX = M
LENY = N
END IF
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (LENX-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through 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,LENY
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
TEMP = ALPHA*X(JX)
DO 50 I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
TEMP = ALPHA*X(JX)
IY = KY
DO 70 I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A**T*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = ZERO
DO 90 I = 1,M
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
100 CONTINUE
ELSE
DO 120 J = 1,N
TEMP = ZERO
IX = KX
DO 110 I = 1,M
TEMP = TEMP + A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of SGEMV
*
END
*> \brief \b SISNAN tests input for NaN.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION SISNAN( SIN )
*
* .. Scalar Arguments ..
* REAL, INTENT(IN) :: SIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SISNAN returns .TRUE. if its argument is NaN, and .FALSE.
*> otherwise. To be replaced by the Fortran 2003 intrinsic in the
*> future.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIN
*> \verbatim
*> SIN is REAL
*> Input to test for NaN.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
LOGICAL FUNCTION SISNAN( SIN )
*
* -- LAPACK auxiliary routine (version 3.7.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2017
*
* .. Scalar Arguments ..
REAL, INTENT(IN) :: SIN
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL SLAISNAN
EXTERNAL SLAISNAN
* ..
* .. Executable Statements ..
SISNAN = SLAISNAN(SIN,SIN)
RETURN
END
*> \brief \b SLACPY 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 SLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLACPY 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 REAL array, dimension (LDA,N)
*> The m by n matrix A. If UPLO = 'U', only the upper triangle
*> or trapezoid is accessed; if UPLO = 'L', only the lower
*> triangle or trapezoid 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 REAL array, dimension (LDB,N)
*> On exit, B = A in the locations specified by UPLO.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
REAL 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 SLACPY
*
END
*> \brief \b SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
* .. Scalar Arguments ..
* REAL A, B, C, D, P, Q
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLADIV performs complex division in real arithmetic
*>
*> a + i*b
*> p + i*q = ---------
*> c + i*d
*>
*> The algorithm is due to Michael Baudin and Robert L. Smith
*> and can be found in the paper
*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is REAL
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is REAL
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL
*> The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*> P is REAL
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is REAL
*> The scalars p and q in the above expression.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date January 2013
*
*> \ingroup realOTHERauxiliary
*
* =====================================================================
SUBROUTINE SLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* January 2013
*
* .. Scalar Arguments ..
REAL A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL BS
PARAMETER ( BS = 2.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
*
* .. Local Scalars ..
REAL AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLADIV1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
AA = A
BB = B
CC = C
DD = D
AB = MAX( ABS(A), ABS(B) )
CD = MAX( ABS(C), ABS(D) )
S = 1.0E0
OV = SLAMCH( 'Overflow threshold' )
UN = SLAMCH( 'Safe minimum' )
EPS = SLAMCH( 'Epsilon' )
BE = BS / (EPS*EPS)
IF( AB >= HALF*OV ) THEN
AA = HALF * AA
BB = HALF * BB
S = TWO * S
END IF
IF( CD >= HALF*OV ) THEN
CC = HALF * CC
DD = HALF * DD
S = HALF * S
END IF
IF( AB <= UN*BS/EPS ) THEN
AA = AA * BE
BB = BB * BE
S = S / BE
END IF
IF( CD <= UN*BS/EPS ) THEN
CC = CC * BE
DD = DD * BE
S = S * BE
END IF
IF( ABS( D ).LE.ABS( C ) ) THEN
CALL SLADIV1(AA, BB, CC, DD, P, Q)
ELSE
CALL SLADIV1(BB, AA, DD, CC, P, Q)
Q = -Q
END IF
P = P * S
Q = Q * S
*
RETURN
*
* End of SLADIV
*
END
*> \ingroup realOTHERauxiliary
SUBROUTINE SLADIV1( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* January 2013
*
* .. Scalar Arguments ..
REAL A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
*
* .. Local Scalars ..
REAL R, T
* ..
* .. External Functions ..
REAL SLADIV2
EXTERNAL SLADIV2
* ..
* .. Executable Statements ..
*
R = D / C
T = ONE / (C + D * R)
P = SLADIV2(A, B, C, D, R, T)
A = -A
Q = SLADIV2(B, A, C, D, R, T)
*
RETURN
*
* End of SLADIV1
*
END
*> \ingroup realOTHERauxiliary
REAL FUNCTION SLADIV2( A, B, C, D, R, T )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* January 2013
*
* .. Scalar Arguments ..
REAL A, B, C, D, R, T
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
*
* .. Local Scalars ..
REAL BR
* ..
* .. Executable Statements ..
*
IF( R.NE.ZERO ) THEN
BR = B * R
if( BR.NE.ZERO ) THEN
SLADIV2 = (A + BR) * T
ELSE
SLADIV2 = A * T + (B * T) * R
END IF
ELSE
SLADIV2 = (A + D * (B / C)) * T
END IF
*
RETURN
*
* End of SLADIV
*
END
*> \brief \b SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAE2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
*
* .. Scalar Arguments ..
* REAL A, B, C, RT1, RT2
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
*> [ A B ]
*> [ B C ].
*> On return, RT1 is the eigenvalue of larger absolute value, and RT2
*> is the eigenvalue of smaller absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is REAL
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is REAL
*> The (1,2) and (2,1) elements of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*> RT1 is REAL
*> The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*> RT2 is REAL
*> The eigenvalue of smaller absolute value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> RT1 is accurate to a few ulps barring over/underflow.
*>
*> RT2 may be inaccurate if there is massive cancellation in the
*> determinant A*C-B*B; higher precision or correctly rounded or
*> correctly truncated arithmetic would be needed to compute RT2
*> accurately in all cases.
*>
*> Overflow is possible only if RT1 is within a factor of 5 of overflow.
*> Underflow is harmless if the input data is 0 or exceeds
*> underflow_threshold / macheps.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
REAL A, B, C, RT1, RT2
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
* ..
* .. Local Scalars ..
REAL AB, ACMN, ACMX, ADF, DF, RT, SM, TB
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
END IF
RETURN
*
* End of SLAE2
*
END
*> \brief \b SLAED0 used by sstedc. 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 SLAED0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
* WORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED0 computes all eigenvalues and corresponding eigenvectors of a
*> symmetric tridiagonal matrix using the divide and conquer method.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ICOMPQ
*> \verbatim
*> ICOMPQ is INTEGER
*> = 0: Compute eigenvalues only.
*> = 1: Compute eigenvectors of original dense symmetric matrix
*> also. On entry, Q contains the orthogonal matrix used
*> to reduce the original matrix to tridiagonal form.
*> = 2: Compute eigenvalues and eigenvectors of tridiagonal
*> matrix.
*> \endverbatim
*>
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the orthogonal 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 REAL array, dimension (N)
*> On entry, the main diagonal of the tridiagonal matrix.
*> On exit, its eigenvalues.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is REAL array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is REAL array, dimension (LDQ, N)
*> On entry, Q must contain an N-by-N orthogonal matrix.
*> If ICOMPQ = 0 Q is not referenced.
*> If ICOMPQ = 1 On entry, Q is a subset of the columns of the
*> orthogonal matrix used to reduce the full
*> matrix to tridiagonal form corresponding to
*> the subset of the full matrix which is being
*> decomposed at this time.
*> If ICOMPQ = 2 On entry, Q will be the identity matrix.
*> On exit, Q contains the eigenvectors of the
*> tridiagonal matrix.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. If eigenvectors are
*> desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
*> \endverbatim
*>
*> \param[out] QSTORE
*> \verbatim
*> QSTORE is REAL array, dimension (LDQS, N)
*> Referenced only when ICOMPQ = 1. 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. If ICOMPQ = 1,
*> then LDQS >= max(1,N). In any case, LDQS >= 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array,
*> If ICOMPQ = 0 or 1, the dimension of WORK must be at least
*> 1 + 3*N + 2*N*lg N + 3*N**2
*> ( lg( N ) = smallest integer k
*> such that 2^k >= N )
*> If ICOMPQ = 2, the dimension of WORK must be at least
*> 4*N + N**2.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array,
*> If ICOMPQ = 0 or 1, 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 )
*> If ICOMPQ = 2, the dimension of IWORK must be at least
*> 3 + 5*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.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
$ WORK, IWORK, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
$ SPM2, SUBMAT, SUBPBS, TLVLS
REAL TEMP
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, REAL
* ..
* .. 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
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 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
IF( ICOMPQ.NE.2 ) THEN
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( REAL( 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
END IF
*
* 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
IF( ICOMPQ.EQ.2 ) THEN
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 130
IF( ICOMPQ.EQ.1 ) THEN
CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
$ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
$ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
$ LDQS )
END IF
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
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.
* SLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* SLAED7 handles the cases in which eigenvalues only or eigenvalues
* and eigenvectors of a full symmetric matrix (which was reduced to
* tridiagonal form) are desired.
*
IF( ICOMPQ.EQ.2 ) THEN
CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
$ MSD2, WORK( IQ ), IWORK( IQPTR ),
$ IWORK( IPRMPT ), IWORK( IPERM ),
$ IWORK( IGIVPT ), IWORK( IGIVCL ),
$ WORK( IGIVNM ), WORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
END IF
IF( INFO.NE.0 )
$ GO TO 130
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.
*
IF( ICOMPQ.EQ.1 ) THEN
DO 100 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
ELSE IF( ICOMPQ.EQ.2 ) THEN
DO 110 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
ELSE
DO 120 I = 1, N
J = IWORK( INDXQ+I )
WORK( I ) = D( J )
120 CONTINUE
CALL SCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of SLAED0
*
END
*> \brief \b SLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER CUTPNT, INFO, LDQ, N
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER INDXQ( * ), IWORK( * )
* REAL D( * ), Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED1 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 eigenvectors of a tridiagonal matrix. SLAED7 handles
*> the case in which eigenvalues only or eigenvalues and eigenvectors
*> of a full symmetric matrix (which was reduced to tridiagonal form)
*> are desired.
*>
*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
*>
*> where Z = Q**T*u, 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 SLAED2.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine SLAED4 (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,out] D
*> \verbatim
*> D is REAL 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 REAL 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,out] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> On entry, the permutation which separately sorts the two
*> subproblems in D into ascending order.
*> On exit, the permutation which will reintegrate the
*> subproblems back into sorted order,
*> i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is REAL
*> The subdiagonal entry used to create the rank-1 modification.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> The location of the last eigenvalue in the leading sub-matrix.
*> min(1,N) <= CUTPNT <= N/2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (4*N + N**2)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (4*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 = 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.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA \n
*> Modified by Francoise Tisseur, University of Tennessee
*>
* =====================================================================
SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
INTEGER CUTPNT, INFO, LDQ, N
REAL RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
REAL D( * ), Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, N1, N2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED1', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are integer pointers which indicate
* the portion of the workspace
* used by a particular array in SLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = 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.
*
CALL SCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
CPP1 = CUTPNT + 1
CALL SCOPY( N-CUTPNT, Q( CPP1, CPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL SLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
$ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
$ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
$ IWORK( COLTYP ), INFO )
*
IF( INFO.NE.0 )
$ GO TO 20
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
$ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
CALL SLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
$ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
$ WORK( IW ), WORK( IS ), INFO )
IF( INFO.NE.0 )
$ GO TO 20
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of SLAED1
*
END
*> \brief \b SLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
* Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDQ, N, N1
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
* $ INDXQ( * )
* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
* $ W( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED2 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 entry 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
*> The number of non-deflated eigenvalues, and the order of the
*> related secular equation. 0 <= K <=N.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*> N1 is INTEGER
*> The location of the last eigenvalue in the leading sub-matrix.
*> min(1,N) <= N1 <= N/2.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is REAL 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] Q
*> \verbatim
*> Q is REAL array, dimension (LDQ, N)
*> On entry, Q contains the eigenvectors of two submatrices in
*> the two square blocks with corners at (1,1), (N1,N1)
*> and (N1+1, N1+1), (N,N).
*> 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] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> 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 N1 added to their
*> values. Destroyed on exit.
*> \endverbatim
*>
*> \param[in,out] RHO
*> \verbatim
*> RHO is REAL
*> On entry, the off-diagonal element associated with the rank-1
*> cut which originally split the two submatrices which are now
*> being recombined.
*> On exit, RHO has been modified to the value required by
*> SLAED3.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL array, dimension (N)
*> On entry, Z contains the updating vector (the last
*> row of the first sub-eigenvector matrix and the first row of
*> the second sub-eigenvector matrix).
*> On exit, the contents of Z have been destroyed by the updating
*> process.
*> \endverbatim
*>
*> \param[out] DLAMDA
*> \verbatim
*> DLAMDA is REAL array, dimension (N)
*> A copy of the first K eigenvalues which will be used by
*> SLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is REAL array, dimension (N)
*> The first k values of the final deflation-altered z-vector
*> which will be passed to SLAED3.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is REAL array, dimension (N1**2+(N-N1)**2)
*> A copy of the first K eigenvectors which will be used by
*> SLAED3 in a matrix multiply (SGEMM) to solve for the new
*> eigenvectors.
*> \endverbatim
*>
*> \param[out] INDX
*> \verbatim
*> INDX is INTEGER array, dimension (N)
*> The permutation used to sort the contents of DLAMDA into
*> ascending order.
*> \endverbatim
*>
*> \param[out] INDXC
*> \verbatim
*> INDXC is INTEGER array, dimension (N)
*> The permutation used to arrange the columns of the deflated
*> Q matrix into three groups: the first group contains non-zero
*> elements only at and above N1, the second contains
*> non-zero elements only below N1, and the third is dense.
*> \endverbatim
*>
*> \param[out] INDXP
*> \verbatim
*> INDXP is INTEGER array, dimension (N)
*> The permutation used to place deflated values of D at the end
*> of the array. INDXP(1:K) points to the nondeflated D-values
*> and INDXP(K+1:N) points to the deflated eigenvalues.
*> \endverbatim
*>
*> \param[out] COLTYP
*> \verbatim
*> COLTYP is INTEGER array, dimension (N)
*> During execution, a label which will indicate which of the
*> following types a column in the Q2 matrix is:
*> 1 : non-zero in the upper half only;
*> 2 : dense;
*> 3 : non-zero in the lower half only;
*> 4 : deflated.
*> On exit, COLTYP(i) is the number of columns of type i,
*> for i=1 to 4 only.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA \n
*> Modified by Francoise Tisseur, University of Tennessee
*>
* =====================================================================
SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
$ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1. Since z is the concatenation of
* two normalized vectors, norm2(z) = sqrt(2).
*
T = ONE / SQRT( TWO )
CALL SSCAL( N, T, Z, 1 )
*
* RHO = ABS( norm(z)**2 * RHO )
*
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 10 I = N1P1, N
INDXQ( I ) = INDXQ( I ) + N1
10 CONTINUE
*
* re-integrate the deflated parts from the last pass
*
DO 20 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
20 CONTINUE
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
*
* 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
IQ2 = 1
DO 40 J = 1, N
I = INDX( J )
CALL SCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL SLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL SCOPY( N, DLAMDA, 1, D, 1 )
GO TO 190
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.
*
DO 50 I = 1, N1
COLTYP( I ) = 1
50 CONTINUE
DO 60 I = N1P1, N
COLTYP( I ) = 3
60 CONTINUE
*
*
K = 0
K2 = N + 1
DO 70 J = 1, N
NJ = INDX( J )
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
IF( J.EQ.N )
$ GO TO 100
ELSE
PJ = NJ
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
NJ = INDX( J )
IF( J.GT.N )
$ GO TO 100
IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
COLTYP( NJ ) = 4
INDXP( K2 ) = NJ
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( PJ )
C = Z( NJ )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = SLAPY2( C, S )
T = D( NJ ) - D( PJ )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( NJ ) = TAU
Z( PJ ) = ZERO
IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
$ COLTYP( NJ ) = 2
COLTYP( PJ ) = 4
CALL SROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
T = D( PJ )*C**2 + D( NJ )*S**2
D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
D( PJ ) = T
K2 = K2 - 1
I = 1
90 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = PJ
I = I + 1
GO TO 90
ELSE
INDXP( K2+I-1 ) = PJ
END IF
ELSE
INDXP( K2+I-1 ) = PJ
END IF
PJ = NJ
ELSE
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
PJ = NJ
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
DLAMDA( K ) = D( PJ )
W( K ) = Z( PJ )
INDXP( K ) = PJ
*
* Count up the total number of the various types of columns, then
* form a permutation which positions the four column types into
* four uniform groups (although one or more of these groups may be
* empty).
*
DO 110 J = 1, 4
CTOT( J ) = 0
110 CONTINUE
DO 120 J = 1, N
CT = COLTYP( J )
CTOT( CT ) = CTOT( CT ) + 1
120 CONTINUE
*
* PSM(*) = Position in SubMatrix (of types 1 through 4)
*
PSM( 1 ) = 1
PSM( 2 ) = 1 + CTOT( 1 )
PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
K = N - CTOT( 4 )
*
* Fill out the INDXC array so that the permutation which it induces
* will place all type-1 columns first, all type-2 columns next,
* then all type-3's, and finally all type-4's.
*
DO 130 J = 1, N
JS = INDXP( J )
CT = COLTYP( JS )
INDX( PSM( CT ) ) = JS
INDXC( PSM( CT ) ) = J
PSM( CT ) = PSM( CT ) + 1
130 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
I = 1
IQ1 = 1
IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
DO 140 J = 1, CTOT( 1 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
140 CONTINUE
*
DO 150 J = 1, CTOT( 2 )
JS = INDX( I )
CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ1 = IQ1 + N1
IQ2 = IQ2 + N2
150 CONTINUE
*
DO 160 J = 1, CTOT( 3 )
JS = INDX( I )
CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
Z( I ) = D( JS )
I = I + 1
IQ2 = IQ2 + N2
160 CONTINUE
*
IQ1 = IQ2
DO 170 J = 1, CTOT( 4 )
JS = INDX( I )
CALL SCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
IQ2 = IQ2 + N
Z( I ) = D( JS )
I = I + 1
170 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 SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N,
$ Q( 1, K+1 ), LDQ )
CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
END IF
*
* Copy CTOT into COLTYP for referencing in SLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of SLAED2
*
END
*> \brief \b SLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
* CTOT, W, S, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDQ, N, N1
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER CTOT( * ), INDX( * )
* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
* $ S( * ), W( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED3 finds the roots of the secular equation, as defined by the
*> values in D, W, and RHO, between 1 and K. It makes the
*> appropriate calls to SLAED4 and then updates the eigenvectors by
*> multiplying the matrix of eigenvectors of the pair of eigensystems
*> being combined by the matrix of eigenvectors of the K-by-K system
*> which is solved here.
*>
*> This code makes very mild assumptions about floating point
*> arithmetic. It will work on machines with a guard digit in
*> add/subtract, or on those binary machines without guard digits
*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
*> It could conceivably fail on hexadecimal or decimal machines
*> without guard digits, but we know of none.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of terms in the rational function to be solved by
*> SLAED4. K >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows and columns in the Q matrix.
*> N >= K (deflation may result in N>K).
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*> N1 is INTEGER
*> The location of the last eigenvalue in the leading submatrix.
*> min(1,N) <= N1 <= N/2.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is REAL array, dimension (N)
*> D(I) contains the updated eigenvalues for
*> 1 <= I <= K.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is REAL array, dimension (LDQ,N)
*> Initially the first K columns are used as workspace.
*> On output the columns 1 to K contain
*> the updated eigenvectors.
*> \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 REAL
*> The value of the parameter in the rank one update equation.
*> RHO >= 0 required.
*> \endverbatim
*>
*> \param[in,out] DLAMDA
*> \verbatim
*> DLAMDA is REAL array, dimension (K)
*> The first K elements of this array contain the old roots
*> of the deflated updating problem. These are the poles
*> of the secular equation. May be changed on output by
*> having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
*> Cray-2, or Cray C-90, as described above.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is REAL array, dimension (LDQ2*N)
*> The first K columns of this matrix contain the non-deflated
*> eigenvectors for the split problem.
*> \endverbatim
*>
*> \param[in] INDX
*> \verbatim
*> INDX is INTEGER array, dimension (N)
*> The permutation used to arrange the columns of the deflated
*> Q matrix into three groups (see SLAED2).
*> The rows of the eigenvectors found by SLAED4 must be likewise
*> permuted before the matrix multiply can take place.
*> \endverbatim
*>
*> \param[in] CTOT
*> \verbatim
*> CTOT is INTEGER array, dimension (4)
*> A count of the total number of the various types of columns
*> in Q, as described in INDX. The fourth column type is any
*> column which has been deflated.
*> \endverbatim
*>
*> \param[in,out] W
*> \verbatim
*> W is REAL array, dimension (K)
*> The first K elements of this array contain the components
*> of the deflation-adjusted updating vector. Destroyed on
*> output.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is REAL array, dimension (N1 + 1)*K
*> Will contain the eigenvectors of the repaired matrix which
*> will be multiplied by the previously accumulated eigenvectors
*> to update the system.
*> \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.
*
*> \date June 2017
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA \n
*> Modified by Francoise Tisseur, University of Tennessee
*>
* =====================================================================
SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
$ CTOT, W, S, INFO )
*
* -- LAPACK computational routine (version 3.7.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2017
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDQ, N, N1
REAL RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.K ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED3', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, K
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 )
$ GO TO 110
IF( K.EQ.2 ) THEN
DO 30 J = 1, K
W( 1 ) = Q( 1, J )
W( 2 ) = Q( 2, J )
II = INDX( 1 )
Q( 1, J ) = W( II )
II = INDX( 2 )
Q( 2, J ) = W( II )
30 CONTINUE
GO TO 110
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
DO 60 J = 1, K
DO 40 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
40 CONTINUE
DO 50 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
60 CONTINUE
DO 70 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
70 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 100 J = 1, K
DO 80 I = 1, K
S( I ) = W( I ) / Q( I, J )
80 CONTINUE
TEMP = SNRM2( K, S, 1 )
DO 90 I = 1, K
II = INDX( I )
Q( I, J ) = S( II ) / TEMP
90 CONTINUE
100 CONTINUE
*
* Compute the updated eigenvectors.
*
110 CONTINUE
*
N2 = N - N1
N12 = CTOT( 1 ) + CTOT( 2 )
N23 = CTOT( 2 ) + CTOT( 3 )
*
CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of SLAED3
*
END
*> \brief \b SLAED4 used by sstedc. Finds a single root of the secular equation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED4 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* .. Scalar Arguments ..
* INTEGER I, INFO, N
* REAL DLAM, RHO
* ..
* .. Array Arguments ..
* REAL D( * ), DELTA( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This subroutine computes the I-th updated eigenvalue of a symmetric
*> rank-one modification to a diagonal matrix whose elements are
*> given in the array d, and that
*>
*> D(i) < D(j) for i < j
*>
*> and that RHO > 0. This is arranged by the calling routine, and is
*> no loss in generality. The rank-one modified system is thus
*>
*> diag( D ) + RHO * Z * Z_transpose.
*>
*> where we assume the Euclidean norm of Z is 1.
*>
*> The method consists of approximating the rational functions in the
*> secular equation by simpler interpolating rational functions.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of all arrays.
*> \endverbatim
*>
*> \param[in] I
*> \verbatim
*> I is INTEGER
*> The index of the eigenvalue to be computed. 1 <= I <= N.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL array, dimension (N)
*> The original eigenvalues. It is assumed that they are in
*> order, D(I) < D(J) for I < J.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL array, dimension (N)
*> The components of the updating vector.
*> \endverbatim
*>
*> \param[out] DELTA
*> \verbatim
*> DELTA is REAL array, dimension (N)
*> If N > 2, DELTA contains (D(j) - lambda_I) in its j-th
*> component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5
*> for detail. The vector DELTA contains the information necessary
*> to construct the eigenvectors by SLAED3 and SLAED9.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is REAL
*> The scalar in the symmetric updating formula.
*> \endverbatim
*>
*> \param[out] DLAM
*> \verbatim
*> DLAM is REAL
*> The computed lambda_I, the I-th updated eigenvalue.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = 1, the updating process failed.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> Logical variable ORGATI (origin-at-i?) is used for distinguishing
*> whether D(i) or D(i+1) is treated as the origin.
*>
*> ORGATI = .true. origin at i
*> ORGATI = .false. origin at i+1
*>
*> Logical variable SWTCH3 (switch-for-3-poles?) is for noting
*> if we are working with THREE poles!
*>
*> MAXIT is the maximum number of iterations allowed for each
*> eigenvalue.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Ren-Cang Li, Computer Science Division, University of California
*> at Berkeley, USA
*>
* =====================================================================
SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER I, INFO, N
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( * ), DELTA( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
$ TEN = 10.0E0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
REAL A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
$ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
$ RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
REAL ZZ( 3 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL SLAED5, SLAED6
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Since this routine is called in an inner loop, we do no argument
* checking.
*
* Quick return for N=1 and 2.
*
INFO = 0
IF( N.EQ.1 ) THEN
*
* Presumably, I=1 upon entry
*
DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
DELTA( 1 ) = ONE
RETURN
END IF
IF( N.EQ.2 ) THEN
CALL SLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = SLAMCH( 'Epsilon' )
RHOINV = ONE / RHO
*
* The case I = N
*
IF( I.EQ.N ) THEN
*
* Initialize some basic variables
*
II = N - 1
NITER = 1
*
* Calculate initial guess
*
MIDPT = RHO / TWO
*
* If ||Z||_2 is not one, then TEMP should be set to
* RHO * ||Z||_2^2 / TWO
*
DO 10 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
10 CONTINUE
*
PSI = ZERO
DO 20 J = 1, N - 2
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
20 CONTINUE
*
C = RHOINV + PSI
W = C + Z( II )*Z( II ) / DELTA( II ) +
$ Z( N )*Z( N ) / DELTA( N )
*
IF( W.LE.ZERO ) THEN
TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
$ Z( N )*Z( N ) / RHO
IF( C.LE.TEMP ) THEN
TAU = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
END IF
*
* It can be proved that
* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
*
DLTLB = MIDPT
DLTUB = RHO
ELSE
DEL = D( N ) - D( N-1 )
A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
B = Z( N )*Z( N )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
ELSE
TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
END IF
*
* It can be proved that
* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
*
DLTLB = ZERO
DLTUB = MIDPT
END IF
*
DO 30 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
30 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 40 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
40 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( C.LT.ZERO )
$ C = ABS( C )
IF( C.EQ.ZERO ) THEN
* ETA = B/A
* ETA = RHO - TAU
ETA = DLTUB - TAU
ELSE IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 50 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
50 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 60 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
60 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 90 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
DLAM = D( I ) + TAU
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
A = ( DELTA( N-1 )+DELTA( N ) )*W -
$ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
B = DELTA( N-1 )*DELTA( N )*W
IF( A.GE.ZERO ) THEN
ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GT.ZERO )
$ ETA = -W / ( DPSI+DPHI )
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
DO 70 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
70 CONTINUE
*
TAU = TAU + ETA
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 80 J = 1, II
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
80 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
TEMP = Z( N ) / DELTA( N )
PHI = Z( N )*TEMP
DPHI = TEMP*TEMP
ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
$ ABS( TAU )*( DPSI+DPHI )
*
W = RHOINV + PHI + PSI
90 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
DLAM = D( I ) + TAU
GO TO 250
*
* End for the case I = N
*
ELSE
*
* The case for I < N
*
NITER = 1
IP1 = I + 1
*
* Calculate initial guess
*
DEL = D( IP1 ) - D( I )
MIDPT = DEL / TWO
DO 100 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
100 CONTINUE
*
PSI = ZERO
DO 110 J = 1, I - 1
PSI = PSI + Z( J )*Z( J ) / DELTA( J )
110 CONTINUE
*
PHI = ZERO
DO 120 J = N, I + 2, -1
PHI = PHI + Z( J )*Z( J ) / DELTA( J )
120 CONTINUE
C = RHOINV + PSI + PHI
W = C + Z( I )*Z( I ) / DELTA( I ) +
$ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
*
IF( W.GT.ZERO ) THEN
*
* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
*
* We choose d(i) as origin.
*
ORGATI = .TRUE.
A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
B = Z( I )*Z( I )*DEL
IF( A.GT.ZERO ) THEN
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
ELSE
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = ZERO
DLTUB = MIDPT
ELSE
*
* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
*
* We choose d(i+1) as origin.
*
ORGATI = .FALSE.
A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
B = Z( IP1 )*Z( IP1 )*DEL
IF( A.LT.ZERO ) THEN
TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
ELSE
TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
END IF
DLTLB = -MIDPT
DLTUB = ZERO
END IF
*
IF( ORGATI ) THEN
DO 130 J = 1, N
DELTA( J ) = ( D( J )-D( I ) ) - TAU
130 CONTINUE
ELSE
DO 140 J = 1, N
DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
140 CONTINUE
END IF
IF( ORGATI ) THEN
II = I
ELSE
II = I + 1
END IF
IIM1 = II - 1
IIP1 = II + 1
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 150 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
150 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 160 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
160 CONTINUE
*
W = RHOINV + PHI + PSI
*
* W is the value of the secular function with
* its ii-th element removed.
*
SWTCH3 = .FALSE.
IF( ORGATI ) THEN
IF( W.LT.ZERO )
$ SWTCH3 = .TRUE.
ELSE
IF( W.GT.ZERO )
$ SWTCH3 = .TRUE.
END IF
IF( II.EQ.1 .OR. II.EQ.N )
$ SWTCH3 = .FALSE.
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = W + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
NITER = NITER + 1
IF( .NOT.SWTCH3 ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
$ ( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
$ ( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
$ ( DPSI+DPHI )
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
ZZ( 2 ) = Z( II )*Z( II )
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
PREW = W
*
DO 180 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
180 CONTINUE
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 190 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
190 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 200 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
200 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
*
SWTCH = .FALSE.
IF( ORGATI ) THEN
IF( -W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
ELSE
IF( W.GT.ABS( PREW ) / TEN )
$ SWTCH = .TRUE.
END IF
*
TAU = TAU + ETA
*
* Main loop to update the values of the array DELTA
*
ITER = NITER + 1
*
DO 240 NITER = ITER, MAXIT
*
* Test for convergence
*
IF( ABS( W ).LE.EPS*ERRETM ) THEN
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
GO TO 250
END IF
*
IF( W.LE.ZERO ) THEN
DLTLB = MAX( DLTLB, TAU )
ELSE
DLTUB = MIN( DLTUB, TAU )
END IF
*
* Calculate the new step
*
IF( .NOT.SWTCH3 ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
C = W - DELTA( IP1 )*DW -
$ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
ELSE
C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
$ ( Z( IP1 ) / DELTA( IP1 ) )**2
END IF
ELSE
TEMP = Z( II ) / DELTA( II )
IF( ORGATI ) THEN
DPSI = DPSI + TEMP*TEMP
ELSE
DPHI = DPHI + TEMP*TEMP
END IF
C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
END IF
A = ( DELTA( I )+DELTA( IP1 ) )*W -
$ DELTA( I )*DELTA( IP1 )*DW
B = DELTA( I )*DELTA( IP1 )*W
IF( C.EQ.ZERO ) THEN
IF( A.EQ.ZERO ) THEN
IF( .NOT.SWTCH ) THEN
IF( ORGATI ) THEN
A = Z( I )*Z( I ) + DELTA( IP1 )*
$ DELTA( IP1 )*( DPSI+DPHI )
ELSE
A = Z( IP1 )*Z( IP1 ) +
$ DELTA( I )*DELTA( I )*( DPSI+DPHI )
END IF
ELSE
A = DELTA( I )*DELTA( I )*DPSI +
$ DELTA( IP1 )*DELTA( IP1 )*DPHI
END IF
END IF
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
ELSE
*
* Interpolation using THREE most relevant poles
*
TEMP = RHOINV + PSI + PHI
IF( SWTCH ) THEN
C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
ELSE
IF( ORGATI ) THEN
TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
$ ( D( IIM1 )-D( IIP1 ) )*TEMP1
ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
$ ( ( DPSI-TEMP1 )+DPHI )
ELSE
TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
TEMP1 = TEMP1*TEMP1
C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
$ ( D( IIP1 )-D( IIM1 ) )*TEMP1
ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
$ ( DPSI+( DPHI-TEMP1 ) )
ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
END IF
END IF
CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
$ INFO )
IF( INFO.NE.0 )
$ GO TO 250
END IF
*
* Note, eta should be positive if w is negative, and
* eta should be negative otherwise. However,
* if for some reason caused by roundoff, eta*w > 0,
* we simply use one Newton step instead. This way
* will guarantee eta*w < 0.
*
IF( W*ETA.GE.ZERO )
$ ETA = -W / DW
TEMP = TAU + ETA
IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
IF( W.LT.ZERO ) THEN
ETA = ( DLTUB-TAU ) / TWO
ELSE
ETA = ( DLTLB-TAU ) / TWO
END IF
END IF
*
DO 210 J = 1, N
DELTA( J ) = DELTA( J ) - ETA
210 CONTINUE
*
TAU = TAU + ETA
PREW = W
*
* Evaluate PSI and the derivative DPSI
*
DPSI = ZERO
PSI = ZERO
ERRETM = ZERO
DO 220 J = 1, IIM1
TEMP = Z( J ) / DELTA( J )
PSI = PSI + Z( J )*TEMP
DPSI = DPSI + TEMP*TEMP
ERRETM = ERRETM + PSI
220 CONTINUE
ERRETM = ABS( ERRETM )
*
* Evaluate PHI and the derivative DPHI
*
DPHI = ZERO
PHI = ZERO
DO 230 J = N, IIP1, -1
TEMP = Z( J ) / DELTA( J )
PHI = PHI + Z( J )*TEMP
DPHI = DPHI + TEMP*TEMP
ERRETM = ERRETM + PHI
230 CONTINUE
*
TEMP = Z( II ) / DELTA( II )
DW = DPSI + DPHI + TEMP*TEMP
TEMP = Z( II )*TEMP
W = RHOINV + PHI + PSI + TEMP
ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
$ THREE*ABS( TEMP ) + ABS( TAU )*DW
IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
$ SWTCH = .NOT.SWTCH
*
240 CONTINUE
*
* Return with INFO = 1, NITER = MAXIT and not converged
*
INFO = 1
IF( ORGATI ) THEN
DLAM = D( I ) + TAU
ELSE
DLAM = D( IP1 ) + TAU
END IF
*
END IF
*
250 CONTINUE
*
RETURN
*
* End of SLAED4
*
END
*> \brief \b SLAED5 used by sstedc. Solves the 2-by-2 secular equation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED5 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* .. Scalar Arguments ..
* INTEGER I
* REAL DLAM, RHO
* ..
* .. Array Arguments ..
* REAL D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This subroutine computes the I-th eigenvalue of a symmetric rank-one
*> modification of a 2-by-2 diagonal matrix
*>
*> diag( D ) + RHO * Z * transpose(Z) .
*>
*> The diagonal elements in the array D are assumed to satisfy
*>
*> D(i) < D(j) for i < j .
*>
*> We also assume RHO > 0 and that the Euclidean norm of the vector
*> Z is one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] I
*> \verbatim
*> I is INTEGER
*> The index of the eigenvalue to be computed. I = 1 or I = 2.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL array, dimension (2)
*> The original eigenvalues. We assume D(1) < D(2).
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL array, dimension (2)
*> The components of the updating vector.
*> \endverbatim
*>
*> \param[out] DELTA
*> \verbatim
*> DELTA is REAL array, dimension (2)
*> The vector DELTA contains the information necessary
*> to construct the eigenvectors.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is REAL
*> The scalar in the symmetric updating formula.
*> \endverbatim
*>
*> \param[out] DLAM
*> \verbatim
*> DLAM is REAL
*> The computed lambda_I, the I-th updated eigenvalue.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Ren-Cang Li, Computer Science Division, University of California
*> at Berkeley, USA
*>
* =====================================================================
SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER I
REAL DLAM, RHO
* ..
* .. Array Arguments ..
REAL D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ FOUR = 4.0E0 )
* ..
* .. Local Scalars ..
REAL B, C, DEL, TAU, TEMP, W
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
DEL = D( 2 ) - D( 1 )
IF( I.EQ.1 ) THEN
W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
IF( W.GT.ZERO ) THEN
B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 1 )*Z( 1 )*DEL
*
* B > ZERO, always
*
TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
DLAM = D( 1 ) + TAU
DELTA( 1 ) = -Z( 1 ) / TAU
DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
ELSE
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
ELSE
TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
END IF
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
ELSE
*
* Now I=2
*
B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
C = RHO*Z( 2 )*Z( 2 )*DEL
IF( B.GT.ZERO ) THEN
TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
ELSE
TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
END IF
DLAM = D( 2 ) + TAU
DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
DELTA( 2 ) = -Z( 2 ) / TAU
TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
DELTA( 1 ) = DELTA( 1 ) / TEMP
DELTA( 2 ) = DELTA( 2 ) / TEMP
END IF
RETURN
*
* End OF SLAED5
*
END
*> \brief \b SLAED6 used by sstedc. Computes one Newton step in solution of the secular equation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED6 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* .. Scalar Arguments ..
* LOGICAL ORGATI
* INTEGER INFO, KNITER
* REAL FINIT, RHO, TAU
* ..
* .. Array Arguments ..
* REAL D( 3 ), Z( 3 )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED6 computes the positive or negative root (closest to the origin)
*> of
*> z(1) z(2) z(3)
*> f(x) = rho + --------- + ---------- + ---------
*> d(1)-x d(2)-x d(3)-x
*>
*> It is assumed that
*>
*> if ORGATI = .true. the root is between d(2) and d(3);
*> otherwise it is between d(1) and d(2)
*>
*> This routine will be called by SLAED4 when necessary. In most cases,
*> the root sought is the smallest in magnitude, though it might not be
*> in some extremely rare situations.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] KNITER
*> \verbatim
*> KNITER is INTEGER
*> Refer to SLAED4 for its significance.
*> \endverbatim
*>
*> \param[in] ORGATI
*> \verbatim
*> ORGATI is LOGICAL
*> If ORGATI is true, the needed root is between d(2) and
*> d(3); otherwise it is between d(1) and d(2). See
*> SLAED4 for further details.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is REAL
*> Refer to the equation f(x) above.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL array, dimension (3)
*> D satisfies d(1) < d(2) < d(3).
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL array, dimension (3)
*> Each of the elements in z must be positive.
*> \endverbatim
*>
*> \param[in] FINIT
*> \verbatim
*> FINIT is REAL
*> The value of f at 0. It is more accurate than the one
*> evaluated inside this routine (if someone wants to do
*> so).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is REAL
*> The root of the equation f(x).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = 1, failure to converge
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 10/02/03: This version has a few statements commented out for thread
*> safety (machine parameters are computed on each entry). SJH.
*>
*> 05/10/06: Modified from a new version of Ren-Cang Li, use
*> Gragg-Thornton-Warner cubic convergent scheme for better stability.
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Ren-Cang Li, Computer Science Division, University of California
*> at Berkeley, USA
*>
* =====================================================================
SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
LOGICAL ORGATI
INTEGER INFO, KNITER
REAL FINIT, RHO, TAU
* ..
* .. Array Arguments ..
REAL D( 3 ), Z( 3 )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
* ..
* .. External Functions ..
REAL SLAMCH
EXTERNAL SLAMCH
* ..
* .. Local Arrays ..
REAL DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL SCALE
INTEGER I, ITER, NITER
REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
$ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
$ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
$ LBD, UBD
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
IF( ORGATI ) THEN
LBD = D(2)
UBD = D(3)
ELSE
LBD = D(1)
UBD = D(2)
END IF
IF( FINIT .LT. ZERO )THEN
LBD = ZERO
ELSE
UBD = ZERO
END IF
*
NITER = 1
TAU = ZERO
IF( KNITER.EQ.2 ) THEN
IF( ORGATI ) THEN
TEMP = ( D( 3 )-D( 2 ) ) / TWO
C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
ELSE
TEMP = ( D( 1 )-D( 2 ) ) / TWO
C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
END IF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
TAU = B / A
ELSE IF( A.LE.ZERO ) THEN
TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD+UBD )/TWO
IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
TAU = ZERO
ELSE
TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
$ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
$ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
IF( TEMP .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
IF( ABS( FINIT ).LE.ABS( TEMP ) )
$ TAU = ZERO
END IF
END IF
*
* get machine parameters for possible scaling to avoid overflow
*
* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
* SMINV2, EPS are not SAVEd anymore between one call to the
* others but recomputed at each call
*
EPS = SLAMCH( 'Epsilon' )
BASE = SLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( SLAMCH( 'SafMin' ) ) / LOG( BASE ) /
$ THREE ) )
SMINV1 = ONE / SMALL1
SMALL2 = SMALL1*SMALL1
SMINV2 = SMINV1*SMINV1
*
* Determine if scaling of inputs necessary to avoid overflow
* when computing 1/TEMP**3
*
IF( ORGATI ) THEN
TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
ELSE
TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
END IF
SCALE = .FALSE.
IF( TEMP.LE.SMALL1 ) THEN
SCALE = .TRUE.
IF( TEMP.LE.SMALL2 ) THEN
*
* Scale up by power of radix nearest 1/SAFMIN**(2/3)
*
SCLFAC = SMINV2
SCLINV = SMALL2
ELSE
*
* Scale up by power of radix nearest 1/SAFMIN**(1/3)
*
SCLFAC = SMINV1
SCLINV = SMALL1
END IF
*
* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
*
DO 10 I = 1, 3
DSCALE( I ) = D( I )*SCLFAC
ZSCALE( I ) = Z( I )*SCLFAC
10 CONTINUE
TAU = TAU*SCLFAC
LBD = LBD*SCLFAC
UBD = UBD*SCLFAC
ELSE
*
* Copy D and Z to DSCALE and ZSCALE
*
DO 20 I = 1, 3
DSCALE( I ) = D( I )
ZSCALE( I ) = Z( I )
20 CONTINUE
END IF
*
FC = ZERO
DF = ZERO
DDF = ZERO
DO 30 I = 1, 3
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
FC = FC + TEMP1 / DSCALE( I )
DF = DF + TEMP2
DDF = DDF + TEMP3
30 CONTINUE
F = FINIT + TAU*FC
*
IF( ABS( F ).LE.ZERO )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
*
* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
* scheme
*
* It is not hard to see that
*
* 1) Iterations will go up monotonically
* if FINIT < 0;
*
* 2) Iterations will go down monotonically
* if FINIT > 0.
*
ITER = NITER + 1
*
DO 50 NITER = ITER, MAXIT
*
IF( ORGATI ) THEN
TEMP1 = DSCALE( 2 ) - TAU
TEMP2 = DSCALE( 3 ) - TAU
ELSE
TEMP1 = DSCALE( 1 ) - TAU
TEMP2 = DSCALE( 2 ) - TAU
END IF
A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
B = TEMP1*TEMP2*F
C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
A = A / TEMP
B = B / TEMP
C = C / TEMP
IF( C.EQ.ZERO ) THEN
ETA = B / A
ELSE IF( A.LE.ZERO ) THEN
ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
ELSE
ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
END IF
IF( F*ETA.GE.ZERO ) THEN
ETA = -F / DF
END IF
*
TAU = TAU + ETA
IF( TAU .LT. LBD .OR. TAU .GT. UBD )
$ TAU = ( LBD + UBD )/TWO
*
FC = ZERO
ERRETM = ZERO
DF = ZERO
DDF = ZERO
DO 40 I = 1, 3
IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN
TEMP = ONE / ( DSCALE( I )-TAU )
TEMP1 = ZSCALE( I )*TEMP
TEMP2 = TEMP1*TEMP
TEMP3 = TEMP2*TEMP
TEMP4 = TEMP1 / DSCALE( I )
FC = FC + TEMP4
ERRETM = ERRETM + ABS( TEMP4 )
DF = DF + TEMP2
DDF = DDF + TEMP3
ELSE
GO TO 60
END IF
40 CONTINUE
F = FINIT + TAU*FC
ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
$ ABS( TAU )*DF
IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR.
$ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) )
$ GO TO 60
IF( F .LE. ZERO )THEN
LBD = TAU
ELSE
UBD = TAU
END IF
50 CONTINUE
INFO = 1
60 CONTINUE
*
* Undo scaling
*
IF( SCALE )
$ TAU = TAU*SCLINV
RETURN
*
* End of SLAED6
*
END
*> \brief \b SLAED7 used by sstedc. 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 SLAED7 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
* LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
* PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
* $ QSIZ, TLVLS
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
* REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
* $ QSTORE( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED7 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 symmetric matrix
*> that has been reduced to tridiagonal form. SLAED1 handles
*> the case in which all eigenvalues and eigenvectors of a symmetric
*> tridiagonal matrix are desired.
*>
*> T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
*>
*> where Z = Q**Tu, 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 SLAED8.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine SLAED4 (as called by SLAED9).
*> 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] ICOMPQ
*> \verbatim
*> ICOMPQ is INTEGER
*> = 0: Compute eigenvalues only.
*> = 1: Compute eigenvectors of original dense symmetric matrix
*> also. On entry, Q contains the orthogonal 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] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the orthogonal matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*> \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 REAL 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 REAL 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[out] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> The permutation which will reintegrate the subproblem just
*> solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
*> will be in ascending order.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is REAL
*> The subdiagonal element used to create the rank-1
*> modification.
*> \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,out] QSTORE
*> \verbatim
*> QSTORE is REAL 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 REAL array, dimension (2, N lg N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (3*N+2*QSIZ*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (4*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 = 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.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
$ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
$ QSIZ, TLVLS
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
* ..
* .. 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
INFO = -2
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED7', -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 SLAED8 and SLAED9.
*
IF( ICOMPQ.EQ.1 ) THEN
LDQ2 = QSIZ
ELSE
LDQ2 = N
END IF
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ2 = IW + N
IS = IQ2 + N*LDQ2
*
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 SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
$ WORK( 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 SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
$ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
$ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
$ IWORK( INDX ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL SLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
$ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( ICOMPQ.EQ.1 ) THEN
CALL SGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
$ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
END IF
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
*
* Prepare the INDXQ sorting permutation.
*
N1 = K
N2 = N - K
CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of SLAED7
*
END
*> \brief \b SLAED8 used by sstedc. 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 SLAED8 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
* CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
* GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* .. Scalar Arguments ..
* INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
* $ QSIZ
* REAL RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
* $ INDXQ( * ), PERM( * )
* REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED8 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[in] ICOMPQ
*> \verbatim
*> ICOMPQ is INTEGER
*> = 0: Compute eigenvalues only.
*> = 1: Compute eigenvectors of original dense symmetric matrix
*> also. On entry, Q contains the orthogonal matrix used
*> to reduce the original matrix to tridiagonal form.
*> \endverbatim
*>
*> \param[out] K
*> \verbatim
*> K is INTEGER
*> The number of non-deflated eigenvalues, and 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 orthogonal matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is REAL array, dimension (N)
*> On entry, the eigenvalues of the two submatrices to be
*> combined. On exit, the trailing (N-K) updated eigenvalues
*> (those which were deflated) sorted into increasing order.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is REAL array, dimension (LDQ,N)
*> If ICOMPQ = 0, Q is not referenced. Otherwise,
*> 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] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> 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[in,out] RHO
*> \verbatim
*> RHO is REAL
*> On entry, the off-diagonal element associated with the rank-1
*> cut which originally split the two submatrices which are now
*> being recombined.
*> On exit, RHO has been modified to the value required by
*> SLAED3.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> The location of the last eigenvalue in the leading
*> sub-matrix. min(1,N) <= CUTPNT <= N.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL array, dimension (N)
*> On entry, Z contains the updating vector (the last row of
*> the first sub-eigenvector matrix and the first row of the
*> second sub-eigenvector matrix).
*> On exit, the contents of Z are destroyed by the updating
*> process.
*> \endverbatim
*>
*> \param[out] DLAMDA
*> \verbatim
*> DLAMDA is REAL array, dimension (N)
*> A copy of the first K eigenvalues which will be used by
*> SLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is REAL array, dimension (LDQ2,N)
*> If ICOMPQ = 0, Q2 is not referenced. Otherwise,
*> a copy of the first K eigenvectors which will be used by
*> SLAED7 in a matrix multiply (SGEMM) 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 REAL array, dimension (N)
*> The first k values of the final deflation-altered z-vector and
*> will be passed to SLAED3.
*> \endverbatim
*>
*> \param[out] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N)
*> The permutations (from deflation and sorting) to be applied
*> to each eigenblock.
*> \endverbatim
*>
*> \param[out] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER
*> 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 REAL array, dimension (2, N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[out] INDXP
*> \verbatim
*> INDXP is INTEGER array, dimension (N)
*> The permutation used to place deflated values of D at the end
*> of the array. 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)
*> The permutation used to sort the contents of D into ascending
*> order.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
$ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
$ GIVCOL, GIVNUM, INDXP, INDX, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
$ QSIZ
REAL RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
$ TWO = 2.0E0, EIGHT = 8.0E0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
REAL C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER ISAMAX
REAL SLAMCH, SLAPY2
EXTERNAL ISAMAX, SLAMCH, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. 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
INFO = -3
ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -10
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -14
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED8', -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 SSCAL( 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 SSCAL( 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
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
DO 40 I = 1, N
D( I ) = DLAMDA( INDX( I ) )
Z( I ) = W( INDX( I ) )
40 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = ISAMAX( N, Z, 1 )
JMAX = ISAMAX( N, D, 1 )
EPS = SLAMCH( '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
IF( ICOMPQ.EQ.0 ) THEN
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
50 CONTINUE
ELSE
DO 60 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL SLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
$ LDQ )
END IF
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 70 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 110
ELSE
JLAM = J
GO TO 80
END IF
70 CONTINUE
80 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 100
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 = SLAPY2( 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
IF( ICOMPQ.EQ.1 ) THEN
CALL SROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
END IF
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
90 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 90
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 )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
JLAM = J
END IF
END IF
GO TO 80
100 CONTINUE
*
* Record the last eigenvalue.
*
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
110 CONTINUE
*
* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
* and Q2 respectively. The eigenvalues/vectors which were not
* deflated go into the first K slots of DLAMDA and Q2 respectively,
* while those which were deflated go into the last N - K slots.
*
IF( ICOMPQ.EQ.0 ) THEN
DO 120 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
120 CONTINUE
ELSE
DO 130 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
130 CONTINUE
END IF
*
* 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
IF( ICOMPQ.EQ.0 ) THEN
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL SLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of SLAED8
*
END
*> \brief \b SLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAED9 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
* S, LDS, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
* REAL RHO
* ..
* .. Array Arguments ..
* REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
* $ W( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAED9 finds the roots of the secular equation, as defined by the
*> values in D, Z, and RHO, between KSTART and KSTOP. It makes the
*> appropriate calls to SLAED4 and then stores the new matrix of
*> eigenvectors for use in calculating the next level of Z vectors.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of terms in the rational function to be solved by
*> SLAED4. K >= 0.
*> \endverbatim
*>
*> \param[in] KSTART
*> \verbatim
*> KSTART is INTEGER
*> \endverbatim
*>
*> \param[in] KSTOP
*> \verbatim
*> KSTOP is INTEGER
*> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
*> are to be computed. 1 <= KSTART <= KSTOP <= K.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows and columns in the Q matrix.
*> N >= K (delation may result in N > K).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is REAL array, dimension (N)
*> D(I) contains the updated eigenvalues
*> for KSTART <= I <= KSTOP.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is REAL array, dimension (LDQ,N)
*> \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 REAL
*> The value of the parameter in the rank one update equation.
*> RHO >= 0 required.
*> \endverbatim
*>
*> \param[in] DLAMDA
*> \verbatim
*> DLAMDA is REAL array, dimension (K)
*> The first K elements of this array contain the old roots
*> of the deflated updating problem. These are the poles
*> of the secular equation.
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*> W is REAL array, dimension (K)
*> The first K elements of this array contain the components
*> of the deflation-adjusted updating vector.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is REAL array, dimension (LDS, K)
*> Will contain the eigenvectors of the repaired matrix which
*> will be stored for subsequent Z vector calculation and
*> multiplied by the previously accumulated eigenvectors
*> to update the system.
*> \endverbatim
*>
*> \param[in] LDS
*> \verbatim
*> LDS is INTEGER
*> The leading dimension of S. LDS >= max( 1, K ).
*> \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.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
$ S, LDS, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
REAL RHO
* ..
* .. Array Arguments ..
REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
REAL TEMP
* ..
* .. External Functions ..
REAL SLAMC3, SNRM2
EXTERNAL SLAMC3, SNRM2
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLAED4, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( K.LT.0 ) THEN
INFO = -1
ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
INFO = -2
ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
$ THEN
INFO = -3
ELSE IF( N.LT.K ) THEN
INFO = -4
ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAED9', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( K.EQ.0 )
$ RETURN
*
* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
* be computed with high relative accuracy (barring over/underflow).
* This is a problem on machines without a guard digit in
* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
* which on any of these machines zeros out the bottommost
* bit of DLAMDA(I) if it is 1; this makes the subsequent
* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
* occurs. On binary machines with a guard digit (almost all
* machines) it does not change DLAMDA(I) at all. On hexadecimal
* and decimal machines with a guard digit, it slightly
* changes the bottommost bits of DLAMDA(I). It does not account
* for hexadecimal or decimal machines without guard digits
* (we know of none). We use a subroutine call to compute
* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
* this code.
*
DO 10 I = 1, N
DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
*
* If the zero finder fails, the computation is terminated.
*
IF( INFO.NE.0 )
$ GO TO 120
20 CONTINUE
*
IF( K.EQ.1 .OR. K.EQ.2 ) THEN
DO 40 I = 1, K
DO 30 J = 1, K
S( J, I ) = Q( J, I )
30 CONTINUE
40 CONTINUE
GO TO 120
END IF
*
* Compute updated W.
*
CALL SCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL SCOPY( K, Q, LDQ+1, W, 1 )
DO 70 J = 1, K
DO 50 I = 1, J - 1
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
50 CONTINUE
DO 60 I = J + 1, K
W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
60 CONTINUE
70 CONTINUE
DO 80 I = 1, K
W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
80 CONTINUE
*
* Compute eigenvectors of the modified rank-1 modification.
*
DO 110 J = 1, K
DO 90 I = 1, K
Q( I, J ) = W( I ) / Q( I, J )
90 CONTINUE
TEMP = SNRM2( K, Q( 1, J ), 1 )
DO 100 I = 1, K
S( I, J ) = Q( I, J ) / TEMP
100 CONTINUE
110 CONTINUE
*
120 CONTINUE
RETURN
*
* End of SLAED9
*
END
*> \brief \b SLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAEDA + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
* GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* .. Scalar Arguments ..
* INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
* $ PRMPTR( * ), QPTR( * )
* REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAEDA computes the Z vector corresponding to the merge step in the
*> CURLVLth step of the merge process with TLVLS steps for the CURPBMth
*> problem.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \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] 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 incidentally 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 REAL array, dimension (2, N lg N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*> Q is REAL array, dimension (N**2)
*> Contains the square eigenblocks from previous levels, the
*> starting positions for blocks are given by QPTR.
*> \endverbatim
*>
*> \param[in] QPTR
*> \verbatim
*> QPTR is INTEGER array, dimension (N+2)
*> Contains a list of pointers which indicate where in Q an
*> eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
*> the size of the block.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is REAL array, dimension (N)
*> On output 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).
*> \endverbatim
*>
*> \param[out] ZTEMP
*> \verbatim
*> ZTEMP is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER CURLVL, CURPBM, INFO, N, TLVLS
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
$ PRMPTR( * ), QPTR( * )
REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEMV, SROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC INT, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -1
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLAEDA', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine location of first number in second half.
*
MID = N / 2 + 1
*
* Gather last/first rows of appropriate eigenblocks into center of Z
*
PTR = 1
*
* Determine location of lowest level subproblem in the full storage
* scheme
*
CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these square
* roots.
*
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL SCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL SCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
DO 20 K = MID + BSIZ2, N
Z( K ) = ZERO
20 CONTINUE
*
* Loop through remaining levels 1 -> CURLVL applying the Givens
* rotations and permutation and then multiplying the center matrices
* against the current Z.
*
PTR = 2**TLVLS + 1
DO 70 K = 1, CURLVL - 1
CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
ZPTR1 = MID - PSIZ1
*
* Apply Givens at CURR and CURR+1
*
DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
CALL SROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
$ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
30 CONTINUE
DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
CALL SROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
$ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
$ GIVNUM( 2, I ) )
40 CONTINUE
PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
DO 50 I = 0, PSIZ1 - 1
ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
50 CONTINUE
DO 60 I = 0, PSIZ2 - 1
ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
60 CONTINUE
*
* Multiply Blocks at CURR and CURR+1
*
* Determine size of these matrices. We add HALF to the value of
* the SQRT in case the machine underestimates one of these
* square roots.
*
BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
CALL SGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL SCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
CALL SGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL SCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of SLAEDA
*
END
*> \brief \b SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAEV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* .. Scalar Arguments ..
* REAL A, B, C, CS1, RT1, RT2, SN1
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
*> [ A B ]
*> [ B C ].
*> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
*> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
*> eigenvector for RT1, giving the decomposition
*>
*> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
*> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is REAL
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is REAL
*> The (1,2) element and the conjugate of the (2,1) element of
*> the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*> RT1 is REAL
*> The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*> RT2 is REAL
*> The eigenvalue of smaller absolute value.
*> \endverbatim
*>
*> \param[out] CS1
*> \verbatim
*> CS1 is REAL
*> \endverbatim
*>
*> \param[out] SN1
*> \verbatim
*> SN1 is REAL
*> The vector (CS1, SN1) is a unit right eigenvector for RT1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> RT1 is accurate to a few ulps barring over/underflow.
*>
*> RT2 may be inaccurate if there is massive cancellation in the
*> determinant A*C-B*B; higher precision or correctly rounded or
*> correctly truncated arithmetic would be needed to compute RT2
*> accurately in all cases.
*>
*> CS1 and SN1 are accurate to a few ulps barring over/underflow.
*>
*> Overflow is possible only if RT1 is within a factor of 5 of overflow.
*> Underflow is harmless if the input data is 0 or exceeds
*> underflow_threshold / macheps.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
REAL A, B, C, CS1, RT1, RT2, SN1
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
REAL TWO
PARAMETER ( TWO = 2.0E0 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL HALF
PARAMETER ( HALF = 0.5E0 )
* ..
* .. Local Scalars ..
INTEGER SGN1, SGN2
REAL AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
$ TB, TN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
SGN1 = -1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
SGN1 = 1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
SGN1 = 1
END IF
*
* Compute the eigenvector
*
IF( DF.GE.ZERO ) THEN
CS = DF + RT
SGN2 = 1
ELSE
CS = DF - RT
SGN2 = -1
END IF
ACS = ABS( CS )
IF( ACS.GT.AB ) THEN
CT = -TB / CS
SN1 = ONE / SQRT( ONE+CT*CT )
CS1 = CT*SN1
ELSE
IF( AB.EQ.ZERO ) THEN
CS1 = ONE
SN1 = ZERO
ELSE
TN = -CS / TB
CS1 = ONE / SQRT( ONE+TN*TN )
SN1 = TN*CS1
END IF
END IF
IF( SGN1.EQ.SGN2 ) THEN
TN = CS1
CS1 = -SN1
SN1 = TN
END IF
RETURN
*
* End of SLAEV2
*
END
*> \brief \b SLAISNAN tests input for NaN by comparing two arguments for inequality.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 )
*
* .. Scalar Arguments ..
* REAL, INTENT(IN) :: SIN1, SIN2
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This routine is not for general use. It exists solely to avoid
*> over-optimization in SISNAN.
*>
*> SLAISNAN checks for NaNs by comparing its two arguments for
*> inequality. NaN is the only floating-point value where NaN != NaN
*> returns .TRUE. To check for NaNs, pass the same variable as both
*> arguments.
*>
*> A compiler must assume that the two arguments are
*> not the same variable, and the test will not be optimized away.
*> Interprocedural or whole-program optimization may delete this
*> test. The ISNAN functions will be replaced by the correct
*> Fortran 03 intrinsic once the intrinsic is widely available.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIN1
*> \verbatim
*> SIN1 is REAL
*> \endverbatim
*>
*> \param[in] SIN2
*> \verbatim
*> SIN2 is REAL
*> Two numbers to compare for inequality.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 )
*
* -- LAPACK auxiliary routine (version 3.7.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2017
*
* .. Scalar Arguments ..
REAL, INTENT(IN) :: SIN1, SIN2
* ..
*
* =====================================================================
*
* .. Executable Statements ..
SLAISNAN = (SIN1.NE.SIN2)
RETURN
END
*> \brief \b SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAMRG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )
*
* .. Scalar Arguments ..
* INTEGER N1, N2, STRD1, STRD2
* ..
* .. Array Arguments ..
* INTEGER INDEX( * )
* REAL A( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAMRG will create a permutation list which will merge the elements
*> of A (which is composed of two independently sorted sets) into a
*> single set which is sorted in ascending order.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N1
*> \verbatim
*> N1 is INTEGER
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*> N2 is INTEGER
*> These arguments contain the respective lengths of the two
*> sorted lists to be merged.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension (N1+N2)
*> The first N1 elements of A contain a list of numbers which
*> are sorted in either ascending or descending order. Likewise
*> for the final N2 elements.
*> \endverbatim
*>
*> \param[in] STRD1
*> \verbatim
*> STRD1 is INTEGER
*> \endverbatim
*>
*> \param[in] STRD2
*> \verbatim
*> STRD2 is INTEGER
*> These are the strides to be taken through the array A.
*> Allowable strides are 1 and -1. They indicate whether a
*> subset of A is sorted in ascending (STRDx = 1) or descending
*> (STRDx = -1) order.
*> \endverbatim
*>
*> \param[out] INDEX
*> \verbatim
*> INDEX is INTEGER array, dimension (N1+N2)
*> On exit this array will contain a permutation such that
*> if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
*> sorted in ascending order.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
INTEGER N1, N2, STRD1, STRD2
* ..
* .. Array Arguments ..
INTEGER INDEX( * )
REAL A( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IND1, IND2, N1SV, N2SV
* ..
* .. Executable Statements ..
*
N1SV = N1
N2SV = N2
IF( STRD1.GT.0 ) THEN
IND1 = 1
ELSE
IND1 = N1
END IF
IF( STRD2.GT.0 ) THEN
IND2 = 1 + N1
ELSE
IND2 = N1 + N2
END IF
I = 1
* while ( (N1SV > 0) & (N2SV > 0) )
10 CONTINUE
IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
IF( A( IND1 ).LE.A( IND2 ) ) THEN
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + STRD1
N1SV = N1SV - 1
ELSE
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + STRD2
N2SV = N2SV - 1
END IF
GO TO 10
END IF
* end while
IF( N1SV.EQ.0 ) THEN
DO 20 N1SV = 1, N2SV
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + STRD2
20 CONTINUE
ELSE
* N2SV .EQ. 0
DO 30 N2SV = 1, N1SV
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + STRD1
30 CONTINUE
END IF
*
RETURN
*
* End of SLAMRG
*
END
*> \brief \b SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLANST + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION SLANST( NORM, N, D, E )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLANST returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> real symmetric tridiagonal matrix A.
*> \endverbatim
*>
*> \return SLANST
*> \verbatim
*>
*> SLANST = ( 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 SLANST as described
*> above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, SLANST is
*> set to zero.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is REAL array, dimension (N)
*> The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is REAL array, dimension (N-1)
*> The (n-1) sub-diagonal or super-diagonal elements of A.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME, SISNAN
EXTERNAL LSAME, SISNAN
* ..
* .. External Subroutines ..
EXTERNAL SLASSQ
* ..
* .. 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
SUM = ABS( D( I ) )
IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM
SUM = ABS( E( I ) )
IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
$ LSAME( NORM, 'I' ) ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = ABS( D( 1 ) )+ABS( E( 1 ) )
SUM = ABS( E( N-1 ) )+ABS( D( N ) )
IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM
DO 20 I = 2, N - 1
SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) )
IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM
20 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( N.GT.1 ) THEN
CALL SLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL SLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
SLANST = ANORM
RETURN
*
* End of SLANST
*
END
*> \brief \b SLAPY2 returns sqrt(x2+y2).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION SLAPY2( X, Y )
*
* .. Scalar Arguments ..
* REAL X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is REAL
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL
*> X and Y specify the values x and y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 3.7.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2017
*
* .. Scalar Arguments ..
REAL X, Y
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
REAL ONE
PARAMETER ( ONE = 1.0E0 )
* ..
* .. Local Scalars ..
REAL W, XABS, YABS, Z
LOGICAL X_IS_NAN, Y_IS_NAN
* ..
* .. External Functions ..
LOGICAL SISNAN
EXTERNAL SISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* ..
* .. Executable Statements ..
*
X_IS_NAN = SISNAN( X )
Y_IS_NAN = SISNAN( Y )
IF ( X_IS_NAN ) SLAPY2 = X
IF ( Y_IS_NAN ) SLAPY2 = Y
*
IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO ) THEN
SLAPY2 = W
ELSE
SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
END IF
RETURN
*
* End of SLAPY2
*
END
*> \brief \b SLAPY3 returns sqrt(x2+y2+z2).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAPY3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* REAL FUNCTION SLAPY3( X, Y, Z )
*
* .. Scalar Arguments ..
* REAL X, Y, Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
*> unnecessary overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is REAL
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is REAL
*> X, Y and Z specify the values x, y and z.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
REAL X, Y, Z
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
REAL W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
* W can be zero for max(0,nan,0)
* adding all three entries together will make sure
* NaN will not disappear.
SLAPY3 = XABS + YABS + ZABS
ELSE
SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of SLAPY3
*
END
!> \brief \b SLARTG generates a plane rotation with real cosine and real sine.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! SUBROUTINE SLARTG( F, G, C, S, R )
!
! .. Scalar Arguments ..
! REAL(wp) C, F, G, R, S
! ..
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> SLARTG generates a plane rotation so that
!>
!> [ C S ] . [ F ] = [ R ]
!> [ -S C ] [ G ] [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!> R = sign(F) * sqrt(F**2 + G**2)
!> C = F / R
!> S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as CLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine SROTG,
!> with the following other differences:
!> F and G are unchanged on return.
!> If G=0, then C=1 and S=0.
!> If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!> floating point operations (saves work in SBDSQR when
!> there are zeros on the diagonal).
!>
!> Below, wp=>sp stands for single precision from LA_CONSTANTS module.
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] F
!> \verbatim
!> F is REAL(wp)
!> The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!> G is REAL(wp)
!> The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!> C is REAL(wp)
!> The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!> S is REAL(wp)
!> The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!> R is REAL(wp)
!> The nonzero component of the rotated vector.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date July 2016
!
!> \ingroup lartg
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
subroutine SLARTG( f, g, c, s, r )
use LA_CONSTANTS, &
only: wp=>sp, zero=>szero, half=>shalf, one=>sone, &
safmin=>ssafmin, safmax=>ssafmax
!
! -- LAPACK auxiliary routine --
! -- LAPACK is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! February 2021
!
! .. Scalar Arguments ..
real(wp) :: c, f, g, r, s
! ..
! .. Local Scalars ..
real(wp) :: d, f1, fs, g1, gs, u, rtmin, rtmax
! ..
! .. Intrinsic Functions ..
intrinsic :: abs, sign, sqrt
! ..
! .. Constants ..
rtmin = sqrt( safmin )
rtmax = sqrt( safmax/2 )
! ..
! .. Executable Statements ..
!
f1 = abs( f )
g1 = abs( g )
if( g == zero ) then
c = one
s = zero
r = f
else if( f == zero ) then
c = zero
s = sign( one, g )
r = g1
else if( f1 > rtmin .and. f1 < rtmax .and. &
g1 > rtmin .and. g1 < rtmax ) then
d = sqrt( f*f + g*g )
c = f1 / d
r = sign( d, f )
s = g / r
else
u = min( safmax, max( safmin, f1, g1 ) )
fs = f / u
gs = g / u
d = sqrt( fs*fs + gs*gs )
c = abs( fs ) / d
r = sign( d, f )
s = gs / r
r = r*u
end if
return
end subroutine
*> \brief \b SLASCL 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 SLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TYPE
* INTEGER INFO, KL, KU, LDA, M, N
* REAL CFROM, CTO
* ..
* .. Array Arguments ..
* REAL A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLASCL multiplies the M by N real 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 SGBTRF 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 REAL
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*> CTO is REAL
*>
*> 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 REAL 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.
*
*> \date June 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
REAL CFROM, CTO
* ..
* .. Array Arguments ..
REAL A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, SISNAN
REAL SLAMCH
EXTERNAL LSAME, SLAMCH, SISNAN
* ..
* .. 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. SISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( SISNAN(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( 'SLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = SLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of SLASCL
*
END
*> \brief \b SLASET 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 SLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* REAL ALPHA, BETA
* ..
* .. Array Arguments ..
* REAL A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLASET initializes an m-by-n matrix 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 strictly lower
*> triangular part of A is not changed.
*> = 'L': Lower triangular part is set; the strictly upper
*> triangular part of A is not changed.
*> Otherwise: All of the matrix A is set.
*> \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] ALPHA
*> \verbatim
*> ALPHA is REAL
*> The constant to which the offdiagonal elements are to be set.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> The constant to which the diagonal elements are to be set.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is REAL array, dimension (LDA,N)
*> On exit, the leading m-by-n submatrix of A is set as follows:
*>
*> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
*> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
*> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
*>
*> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
REAL ALPHA, BETA
* ..
* .. Array Arguments ..
REAL 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 strictly upper triangular or trapezoidal 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
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the strictly lower triangular or trapezoidal part of the
* array to ALPHA.
*
DO 40 J = 1, MIN( M, N )
DO 30 I = J + 1, M
A( I, J ) = ALPHA
30 CONTINUE
40 CONTINUE
*
ELSE
*
* Set the leading m-by-n submatrix to ALPHA.
*
DO 60 J = 1, N
DO 50 I = 1, M
A( I, J ) = ALPHA
50 CONTINUE
60 CONTINUE
END IF
*
* Set the first min(M,N) diagonal elements to BETA.
*
DO 70 I = 1, MIN( M, N )
A( I, I ) = BETA
70 CONTINUE
*
RETURN
*
* End of SLASET
*
END
*> \brief \b SLASR 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 SLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, PIVOT, SIDE
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* REAL A( LDA, * ), C( * ), S( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLASR applies a sequence of plane rotations to a real 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 REAL 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 REAL 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 REAL array, dimension (LDA,N)
*> The M-by-N matrix A. On exit, A is overwritten by P*A if
*> SIDE = 'R' or by A*P**T if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( * ), S( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
REAL CTEMP, STEMP, 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( 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( 'SLASR ', 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 SLASR
*
END
*> \brief \b SLASRT sorts numbers in increasing or decreasing order.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLASRT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLASRT( ID, N, D, INFO )
*
* .. Scalar Arguments ..
* CHARACTER ID
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* REAL D( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Sort the numbers in D in increasing order (if ID = 'I') or
*> in decreasing order (if ID = 'D' ).
*>
*> Use Quick Sort, reverting to Insertion sort on arrays of
*> size <= 20. Dimension of STACK limits N to about 2**32.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ID
*> \verbatim
*> ID is CHARACTER*1
*> = 'I': sort D in increasing order;
*> = 'D': sort D in decreasing order.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of the array D.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is REAL array, dimension (N)
*> On entry, the array to be sorted.
*> On exit, D has been sorted into increasing order
*> (D(1) <= ... <= D(N) ) or into decreasing order
*> (D(1) >= ... >= D(N) ), depending on ID.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE SLASRT( ID, N, D, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER ID
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
REAL D1, D2, D3, DMNMX, TMP
* ..
* .. Local Arrays ..
INTEGER STACK( 2, 32 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DIR = -1
IF( LSAME( ID, 'D' ) ) THEN
DIR = 0
ELSE IF( LSAME( ID, 'I' ) ) THEN
DIR = 1
END IF
IF( DIR.EQ.-1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SLASRT', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
STKPNT = 1
STACK( 1, 1 ) = 1
STACK( 2, 1 ) = N
10 CONTINUE
START = STACK( 1, STKPNT )
ENDD = STACK( 2, STKPNT )
STKPNT = STKPNT - 1
IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
* Do Insertion sort on D( START:ENDD )
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
DO 30 I = START + 1, ENDD
DO 20 J = I, START + 1, -1
IF( D( J ).GT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
*
ELSE
*
* Sort into increasing order
*
DO 50 I = START + 1, ENDD
DO 40 J = I, START + 1, -1
IF( D( J ).LT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
END IF
*
ELSE IF( ENDD-START.GT.SELECT ) THEN
*
* Partition D( START:ENDD ) and stack parts, largest one first
*
* Choose partition entry as median of 3
*
D1 = D( START )
D2 = D( ENDD )
I = ( START+ENDD ) / 2
D3 = D( I )
IF( D1.LT.D2 ) THEN
IF( D3.LT.D1 ) THEN
DMNMX = D1
ELSE IF( D3.LT.D2 ) THEN
DMNMX = D3
ELSE
DMNMX = D2
END IF
ELSE
IF( D3.LT.D2 ) THEN
DMNMX = D2
ELSE IF( D3.LT.D1 ) THEN
DMNMX = D3
ELSE
DMNMX = D1
END IF
END IF
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
I = START - 1
J = ENDD + 1
60 CONTINUE
70 CONTINUE
J = J - 1
IF( D( J ).LT.DMNMX )
$ GO TO 70
80 CONTINUE
I = I + 1
IF( D( I ).GT.DMNMX )
$ GO TO 80
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 60
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
ELSE
*
* Sort into increasing order
*
I = START - 1
J = ENDD + 1
90 CONTINUE
100 CONTINUE
J = J - 1
IF( D( J ).GT.DMNMX )
$ GO TO 100
110 CONTINUE
I = I + 1
IF( D( I ).LT.DMNMX )
$ GO TO 110
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 90
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
END IF
END IF
IF( STKPNT.GT.0 )
$ GO TO 10
RETURN
*
* End of SLASRT
*
END
!> \brief \b SLASSQ updates a sum of squares represented in scaled form.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLASSQ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
! Definition:
! ===========
!
! SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
!
! .. Scalar Arguments ..
! INTEGER INCX, N
! REAL SCALE, SUMSQ
! ..
! .. Array Arguments ..
! REAL X( * )
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> SLASSQ returns the values scale_out and sumsq_out such that
!>
!> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> The number of elements to be used from the vector x.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is REAL array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER
!> The increment between successive values of the vector x.
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!>
!> \param[in,out] SCALE
!> \verbatim
!> SCALE is REAL
!> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares.
!> \endverbatim
!>
!> \param[in,out] SUMSQ
!> \verbatim
!> SUMSQ is REAL
!> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scale_out has been factored out.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!> Nick Papior, Technical University of Denmark, DK
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!
!> \ingroup lassq
!
! =====================================================================
subroutine SLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, &
only: wp=>sp, zero=>szero, one=>sone, &
sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
use LA_XISNAN
!
! -- 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
real(wp) :: scale, sumsq
! ..
! .. Array Arguments ..
real(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, ymax, ymin
! ..
!
! Quick return if possible
!
if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scale = one
if( scale == zero ) then
scale = one
sumsq = zero
end if
if (n <= 0) then
return
end if
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Put the existing sum of squares into one of the accumulators
!
if( sumsq > zero ) then
ax = scale*sqrt( sumsq )
if (ax > tbig) then
if (scale > one) then
scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then
if (notbig) then
if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else
amed = amed + scale * (scale * sumsq)
end if
end if
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig
end if
scale = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scale = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range or zero
!
scale = one
sumsq = amed
end if
return
end subroutine
!> \brief \b SNRM2
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! REAL FUNCTION SNRM2(N,X,INCX)
!
! .. Scalar Arguments ..
! INTEGER INCX,N
! ..
! .. Array Arguments ..
! REAL X(*)
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> SNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!> SNRM2 := sqrt( x'*x ).
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER, storage spacing between elements of X
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup nrm2
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
! =====================================================================
function SNRM2( n, x, incx )
integer, parameter :: wp = kind(1.e0)
real(wp) :: SNRM2
!
! -- Reference BLAS level1 routine (version 3.9.1) --
! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! March 2021
!
! .. Constants ..
real(wp), parameter :: zero = 0.0_wp
real(wp), parameter :: one = 1.0_wp
real(wp), parameter :: maxN = huge(0.0_wp)
! ..
! .. Blue's scaling constants ..
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
(minexponent(0._wp) - 1) * 0.5_wp)
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp))
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp))
! ..
! .. Scalar Arguments ..
integer :: incx, n
! ..
! .. Array Arguments ..
real(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
! Quick return if possible
!
SNRM2 = zero
if( n <= 0 ) return
!
scl = one
sumsq = zero
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range
!
scl = one
sumsq = amed
end if
SNRM2 = scl*sqrt( sumsq )
return
end function
*> \brief \b SROT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
*
* .. Scalar Arguments ..
* REAL C,S
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* REAL SX(*),SY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> applies a plane rotation.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*>
*> \param[in,out] SY
*> \verbatim
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of SY
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is REAL
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is REAL
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup rot
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL C,S
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL STEMP
INTEGER I,IX,IY
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
STEMP = C*SX(I) + S*SY(I)
SY(I) = C*SY(I) - S*SX(I)
SX(I) = STEMP
END DO
ELSE
*
* 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 I = 1,N
STEMP = C*SX(IX) + S*SY(IY)
SY(IY) = C*SY(IY) - S*SX(IX)
SX(IX) = STEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of SROT
*
END
*> \brief \b SSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SSCAL(N,SA,SX,INCX)
*
* .. Scalar Arguments ..
* REAL SA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* REAL SX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSCAL scales a vector by a constant.
*> uses unrolled loops for increment equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is REAL
*> On entry, SA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup scal
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SSCAL(N,SA,SX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL SA
INTEGER INCX,N
* ..
* .. Array Arguments ..
REAL SX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,M,MP1,NINCX
* ..
* .. Parameters ..
REAL ONE
PARAMETER (ONE=1.0E+0)
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
*
* clean-up loop
*
M = MOD(N,5)
IF (M.NE.0) THEN
DO I = 1,M
SX(I) = SA*SX(I)
END DO
IF (N.LT.5) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,5
SX(I) = SA*SX(I)
SX(I+1) = SA*SX(I+1)
SX(I+2) = SA*SX(I+2)
SX(I+3) = SA*SX(I+3)
SX(I+4) = SA*SX(I+4)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
SX(I) = SA*SX(I)
END DO
END IF
RETURN
*
* End of SSCAL
*
END
*> \brief \b SSTEDC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSTEDC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
* LIWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
*> symmetric tridiagonal matrix using the divide and conquer method.
*> The eigenvectors of a full or band real symmetric matrix can also be
*> found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
*> matrix to tridiagonal form.
*>
*> This code makes very mild assumptions about floating point
*> arithmetic. It will work on machines with a guard digit in
*> add/subtract, or on those binary machines without guard digits
*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
*> It could conceivably fail on hexadecimal or decimal machines
*> without guard digits, but we know of none. See SLAED3 for details.
*> \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 dense symmetric
*> matrix also. On entry, Z contains the orthogonal
*> 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 REAL 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 REAL 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 REAL array, dimension (LDZ,N)
*> On entry, if COMPZ = 'V', then Z contains the orthogonal
*> 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 symmetric 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 REAL array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
*> If COMPZ = 'V' and N > 1 then LWORK 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 then LWORK must be at least
*> ( 1 + 4*N + 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 LWORK need
*> only be max(1,2*(N-1)).
*>
*> 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.
*> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
*> If COMPZ = 'V' and N > 1 then LIWORK must be at least
*> ( 6 + 6*N + 5*N*lg N ).
*> If COMPZ = 'I' and N > 1 then 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 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.
*> > 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.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA \n
*> Modified by Francoise Tisseur, University of Tennessee
*>
* =====================================================================
SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
REAL EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
REAL SLAMCH, SLANST
EXTERNAL ILAENV, LSAME, SLAMCH, SLANST
* ..
* .. External Subroutines ..
EXTERNAL SGEMM, SLACPY, SLAED0, SLASCL, SLASET, SLASRT,
$ SSTEQR, SSTERF, SSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.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, 'SSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LIWMIN = 1
LWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LIWMIN = 1
LWMIN = 2*( N - 1 )
ELSE
LGN = INT( LOG( REAL( N ) )/LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( ICOMPZ.EQ.1 ) THEN
LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1 + 4*N + N**2
LIWMIN = 3 + 5*N
END IF
END IF
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
INFO = -8
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
INFO = -10
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSTEDC', -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 SSTERF 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 SSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL SSTERF( N, D, E, INFO )
GO TO 50
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 SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
ELSE
*
* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
* use.
*
IF( ICOMPZ.EQ.1 ) THEN
STOREZ = 1 + N*N
ELSE
STOREZ = 1
END IF
*
IF( ICOMPZ.EQ.2 ) THEN
CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = SLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 50
*
EPS = SLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
10 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
20 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 20
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.EQ.1 ) THEN
START = FINISH + 1
GO TO 10
END IF
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL SLAED0( ICOMPZ, N, M, D( START ), E( START ),
$ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
$ WORK( STOREZ ), IWORK, INFO )
IF( INFO.NE.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 50
END IF
*
* Scale back.
*
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
IF( ICOMPZ.EQ.1 ) THEN
*
* Since QR won't update a Z matrix which is larger than
* the length of D, we must solve the sub-problem in a
* workspace and then multiply back into Z.
*
CALL SSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL SLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
CALL SGEMM( 'N', 'N', N, M, M, ONE,
$ WORK( STOREZ ), N, WORK, M, ZERO,
$ Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL SSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL SSTERF( M, D( START ), E( START ), INFO )
END IF
IF( INFO.NE.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 50
END IF
END IF
*
START = FINISH + 1
GO TO 10
END IF
*
* endwhile
*
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 40 II = 2, N
I = II - 1
K = I
P = D( I )
DO 30 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
30 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
40 CONTINUE
END IF
END IF
*
50 CONTINUE
WORK( 1 ) = LWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of SSTEDC
*
END
*> \brief \b SSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSTEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSTEQR 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 symmetric matrix can also be found
*> if SSYTRD or SSPTRD or SSBTRD 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
*> symmetric matrix. On entry, Z must contain the
*> orthogonal 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 REAL 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 REAL 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 REAL array, dimension (LDZ, N)
*> On entry, if COMPZ = 'V', then Z contains the orthogonal
*> 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 symmetric 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 REAL 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 orthogonally similar to the original
*> matrix.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
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
REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR,
$ SLASRT, SSWAP, XERBLA
* ..
* .. 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( 'SSTEQR', -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 ) = ONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( '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 SLASET( 'Full', N, N, ZERO, ONE, 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 = SLANST( 'M', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( '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 SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 SLASR( '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 SLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 SLASR( '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 SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL SLASCL( '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.LT.NMAXIT )
$ GO TO 10
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
GO TO 190
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL SLASRT( '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 SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of SSTEQR
*
END
*> \brief \b SSTERF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSTERF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SSTERF( N, D, E, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* REAL D( * ), E( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
*> using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is REAL array, dimension (N)
*> On entry, the n diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is REAL array, dimension (N-1)
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
*> matrix.
*> On exit, E has been destroyed.
*> \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 find all of the eigenvalues in
*> a total of 30*N iterations; if INFO = i, then i
*> elements of E have not converged to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE SSTERF( N, D, E, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
REAL D( * ), E( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
$ THREE = 3.0E0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN
* ..
* .. External Functions ..
REAL SLAMCH, SLANST, SLAPY2
EXTERNAL SLAMCH, SLANST, SLAPY2
* ..
* .. External Subroutines ..
EXTERNAL SLAE2, SLASCL, SLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'SSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
EPS = SLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = SLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
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
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
DO 20 M = L1, N - 1
IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*
$ SQRT( ABS( D( M+1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
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 = SLANST( 'M', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
DO 60 M = L, LEND - 1
IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL SLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 80 I = M - 1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
DO 110 M = L, LEND + 1, -1
IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use SLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL SLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = SLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
DO 130 I = M, L - 1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
E( L-1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 )
$ CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.LT.NMAXIT )
$ GO TO 10
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
GO TO 180
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL SLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of SSTERF
*
END
*> \brief \b SSWAP
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* REAL SX(*),SY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSWAP interchanges two vectors.
*> uses unrolled loops for increments equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*>
*> \param[in,out] SY
*> \verbatim
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of SY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup swap
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS 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
* ..
* .. Array Arguments ..
REAL SX(*),SY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
REAL STEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,3)
IF (M.NE.0) THEN
DO I = 1,M
STEMP = SX(I)
SX(I) = SY(I)
SY(I) = STEMP
END DO
IF (N.LT.3) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,3
STEMP = SX(I)
SX(I) = SY(I)
SY(I) = STEMP
STEMP = SX(I+1)
SX(I+1) = SY(I+1)
SY(I+1) = STEMP
STEMP = SX(I+2)
SX(I+2) = SY(I+2)
SY(I+2) = STEMP
END DO
ELSE
*
* 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 I = 1,N
STEMP = SX(IX)
SX(IX) = SY(IY)
SY(IY) = STEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of SSWAP
*
END
*> \brief \b XERBLA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE XERBLA( SRNAME, INFO )
*
* .. Scalar Arguments ..
* CHARACTER*(*) SRNAME
* INTEGER INFO
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> XERBLA is an error handler for the LAPACK routines.
*> It is called by an LAPACK routine if an input parameter has an
*> invalid value. A message is printed and execution stops.
*>
*> Installers may consider modifying the STOP statement in order to
*> call system-specific exception-handling facilities.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SRNAME
*> \verbatim
*> SRNAME is CHARACTER*(*)
*> The name of the routine which called XERBLA.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*> INFO is INTEGER
*> The position of the invalid parameter in the parameter list
*> of the calling routine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup xerbla
*
* =====================================================================
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER*(*) SRNAME
INTEGER INFO
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC LEN_TRIM
* ..
* .. Executable Statements ..
*
WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
*
STOP
*
9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
$ 'an illegal value' )
*
* End of XERBLA
*
END
*> \brief \b SLAMCH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SLAMCH( CMACH )
*
* .. Scalar Arguments ..
* CHARACTER CMACH
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLAMCH determines single precision machine parameters.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CMACH
*> \verbatim
*> CMACH is CHARACTER*1
*> Specifies the value to be returned by SLAMCH:
*> = 'E' or 'e', SLAMCH := eps
*> = 'S' or 's , SLAMCH := sfmin
*> = 'B' or 'b', SLAMCH := base
*> = 'P' or 'p', SLAMCH := eps*base
*> = 'N' or 'n', SLAMCH := t
*> = 'R' or 'r', SLAMCH := rnd
*> = 'M' or 'm', SLAMCH := emin
*> = 'U' or 'u', SLAMCH := rmin
*> = 'L' or 'l', SLAMCH := emax
*> = 'O' or 'o', SLAMCH := rmax
*> where
*> eps = relative machine precision
*> sfmin = safe minimum, such that 1/sfmin does not overflow
*> base = base of the machine
*> prec = eps*base
*> t = number of (base) digits in the mantissa
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
*> emin = minimum exponent before (gradual) underflow
*> rmin = underflow threshold - base**(emin-1)
*> emax = largest exponent before overflow
*> rmax = overflow threshold - (base**emax)*(1-eps)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
REAL FUNCTION SLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER CMACH
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
REAL RND, EPS, SFMIN, SMALL, RMACH
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
$ MINEXPONENT, RADIX, TINY
* ..
* .. Executable Statements ..
*
*
* Assume rounding, not chopping. Always.
*
RND = ONE
*
IF( ONE.EQ.RND ) THEN
EPS = EPSILON(ZERO) * 0.5
ELSE
EPS = EPSILON(ZERO)
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
SFMIN = TINY(ZERO)
SMALL = ONE / HUGE(ZERO)
IF( SMALL.GE.SFMIN ) THEN
*
* Use SMALL plus a bit, to avoid the possibility of rounding
* causing overflow when computing 1/sfmin.
*
SFMIN = SMALL*( ONE+EPS )
END IF
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = EPS * RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = DIGITS(ZERO)
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = MINEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = tiny(zero)
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = MAXEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = HUGE(ZERO)
ELSE
RMACH = ZERO
END IF
*
SLAMCH = RMACH
RETURN
*
* End of SLAMCH
*
END
************************************************************************
*> \brief \b SLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC3 is intended to force A and B to be stored prior to doing
*> the addition of A and B , for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date December 2016
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> The values A and B.
*> \endverbatim
*>
*
REAL FUNCTION SLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2010
*
* .. Scalar Arguments ..
REAL A, B
* ..
* =====================================================================
*
* .. Executable Statements ..
*
SLAMC3 = A + B
*
RETURN
*
* End of SLAMC3
*
END
*
************************************************************************