./PaxHeaders.21776/elk-7.2.42 0000644 0000000 0000000 00000000132 14061636525 012214 x ustar 00 30 mtime=1623670101.157096698
30 atime=1623670090.110106952
30 ctime=1623670101.157096698
elk-7.2.42/ 0000755 0025044 0025044 00000000000 14061636525 014171 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/PaxHeaders.21776/src 0000644 0000000 0000000 00000000131 14061636517 012646 x ustar 00 30 mtime=1623670095.997101488
29 atime=1623670092.98910428
30 ctime=1623670095.997101488
elk-7.2.42/src/ 0000755 0025044 0025044 00000000000 14061636517 014761 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/PaxHeaders.21776/BLAS 0000644 0000000 0000000 00000000132 14061636515 013366 x ustar 00 30 mtime=1623670093.105104172
30 atime=1623670092.996104273
30 ctime=1623670093.105104172
elk-7.2.42/src/BLAS/ 0000755 0025044 0025044 00000000000 14061636515 015500 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/BLAS/PaxHeaders.21776/zdotc.f 0000644 0000000 0000000 00000000127 14061636514 014740 x ustar 00 29 mtime=1623670092.99910427
29 atime=1623670092.99910427
29 ctime=1623670092.99910427
elk-7.2.42/src/BLAS/zdotc.f 0000644 0025044 0025044 00000005644 14061636514 017002 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZDOTC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*),ZY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZDOTC forms the dot product of two complex vectors
*> ZDOTC = X^H * Y
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[in] ZY
*> \verbatim
*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of ZY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*),ZY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
COMPLEX*16 ZTEMP
INTEGER I,IX,IY
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
ZTEMP = (0.0d0,0.0d0)
ZDOTC = (0.0d0,0.0d0)
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
ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(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
ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
ZDOTC = ZTEMP
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zgerc.f 0000644 0000000 0000000 00000000132 14061636515 014724 x ustar 00 30 mtime=1623670093.001104268
30 atime=1623670093.001104268
30 ctime=1623670093.001104268
elk-7.2.42/src/BLAS/zgerc.f 0000644 0025044 0025044 00000013047 14061636515 016766 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGERC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGERC 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 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*16 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*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,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('ZGERC ',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*DCONJG(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*DCONJG(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 ZGERC .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dzasum.f 0000644 0000000 0000000 00000000132 14061636515 015115 x ustar 00 30 mtime=1623670093.004104266
30 atime=1623670093.004104266
30 ctime=1623670093.004104266
elk-7.2.42/src/BLAS/dzasum.f 0000644 0025044 0025044 00000005073 14061636515 017157 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DZASUM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and
*> returns a single precision result.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION STEMP
INTEGER I,NINCX
* ..
* .. External Functions ..
DOUBLE PRECISION DCABS1
EXTERNAL DCABS1
* ..
DZASUM = 0.0d0
STEMP = 0.0d0
IF (N.LE.0 .OR. INCX.LE.0) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DO I = 1,N
STEMP = STEMP + DCABS1(ZX(I))
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
STEMP = STEMP + DCABS1(ZX(I))
END DO
END IF
DZASUM = STEMP
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zherk.f 0000644 0000000 0000000 00000000132 14061636515 014735 x ustar 00 30 mtime=1623670093.007104263
30 atime=1623670093.006104264
30 ctime=1623670093.007104263
elk-7.2.42/src/BLAS/zherk.f 0000644 0025044 0025044 00000027702 14061636515 017002 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHERK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHERK performs one of the hermitian rank k operations
*>
*> C := alpha*A*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*A + beta*C,
*>
*> where alpha and beta are real scalars, C is an n by n hermitian
*> matrix and A is an n by k matrix in the first case and a k by n
*> matrix 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*A**H + beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**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 matrix A, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrix A. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION .
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 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] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 DBLE( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCMPLX,DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
DOUBLE PRECISION RTEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+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 (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHERK ',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.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*DBLE(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.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*DBLE(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*A**H + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.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*DBLE(C(J,J))
ELSE
C(J,J) = DBLE(C(J,J))
END IF
DO 120 L = 1,K
IF (A(J,L).NE.DCMPLX(ZERO)) THEN
TEMP = ALPHA*DCONJG(A(J,L))
DO 110 I = 1,J - 1
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
C(J,J) = DBLE(C(J,J)) + DBLE(TEMP*A(I,L))
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
C(J,J) = BETA*DBLE(C(J,J))
DO 150 I = J + 1,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
ELSE
C(J,J) = DBLE(C(J,J))
END IF
DO 170 L = 1,K
IF (A(J,L).NE.DCMPLX(ZERO)) THEN
TEMP = ALPHA*DCONJG(A(J,L))
C(J,J) = DBLE(C(J,J)) + DBLE(TEMP*A(J,L))
DO 160 I = J + 1,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**H*A + beta*C.
*
IF (UPPER) THEN
DO 220 J = 1,N
DO 200 I = 1,J - 1
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + DCONJG(A(L,I))*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
RTEMP = ZERO
DO 210 L = 1,K
RTEMP = RTEMP + DCONJG(A(L,J))*A(L,J)
210 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*DBLE(C(J,J))
END IF
220 CONTINUE
ELSE
DO 260 J = 1,N
RTEMP = ZERO
DO 230 L = 1,K
RTEMP = RTEMP + DCONJG(A(L,J))*A(L,J)
230 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*DBLE(C(J,J))
END IF
DO 250 I = J + 1,N
TEMP = ZERO
DO 240 L = 1,K
TEMP = TEMP + DCONJG(A(L,I))*A(L,J)
240 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
250 CONTINUE
260 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHERK .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zhpr.f 0000644 0000000 0000000 00000000130 14061636515 014573 x ustar 00 29 mtime=1623670093.01010426
30 atime=1623670093.009104261
29 ctime=1623670093.01010426
elk-7.2.42/src/BLAS/zhpr.f 0000644 0025044 0025044 00000017672 14061636515 016647 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPR performs the hermitian rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a real scalar, x is an n element vector and A is an
*> n by n hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \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,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZHPR(UPLO,N,ALPHA,X,INCX,AP)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHPR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN
*
* Set the start point in X if the increment is not unity.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(J))
K = KK
DO 10 I = 1,J - 1
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
10 CONTINUE
AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP)
ELSE
AP(KK+J-1) = DBLE(AP(KK+J-1))
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(JX))
IX = KX
DO 30 K = KK,KK + J - 2
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP)
ELSE
AP(KK+J-1) = DBLE(AP(KK+J-1))
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(J))
AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(J))
K = KK + 1
DO 50 I = J + 1,N
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
50 CONTINUE
ELSE
AP(KK) = DBLE(AP(KK))
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*DCONJG(X(JX))
AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(JX))
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
AP(K) = AP(K) + X(IX)*TEMP
70 CONTINUE
ELSE
AP(KK) = DBLE(AP(KK))
END IF
JX = JX + INCX
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPR .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dcabs1.f 0000644 0000000 0000000 00000000132 14061636515 014747 x ustar 00 30 mtime=1623670093.012104258
30 atime=1623670093.012104258
30 ctime=1623670093.012104258
elk-7.2.42/src/BLAS/dcabs1.f 0000644 0025044 0025044 00000002565 14061636515 017014 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DCABS1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DCABS1(Z)
*
* .. Scalar Arguments ..
* COMPLEX*16 Z
* ..
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] Z
*> \verbatim
*> Z is COMPLEX*16
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
* =====================================================================
DOUBLE PRECISION FUNCTION DCABS1(Z)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
COMPLEX*16 Z
* ..
* ..
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ABS,DBLE,DIMAG
*
DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z))
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/xerbla.f 0000644 0000000 0000000 00000000132 14061636515 015067 x ustar 00 30 mtime=1623670093.015104255
30 atime=1623670093.014104256
30 ctime=1623670093.015104255
elk-7.2.42/src/BLAS/xerbla.f 0000644 0025044 0025044 00000004150 14061636515 017124 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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.
*
*> \date December 2016
*
*> \ingroup aux_blas
*
* =====================================================================
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- Reference BLAS level1 routine (version 3.7.0) --
* -- Reference BLAS 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*(*) 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
elk-7.2.42/src/BLAS/PaxHeaders.21776/Makefile 0000644 0000000 0000000 00000000132 14061636515 015103 x ustar 00 30 mtime=1623670093.017104254
30 atime=1623670093.017104254
30 ctime=1623670093.017104254
elk-7.2.42/src/BLAS/Makefile 0000644 0025044 0025044 00000002152 14061636515 017140 0 ustar 00dewhurst dewhurst 0000000 0000000
AR = ar
include ../../make.inc
#-------------------------------------------------------------------------------
# Suffix Rules
#-------------------------------------------------------------------------------
.SUFFIXES: .o .f
.f.o:
$(F77) $(F77_OPTS) -c $<
#-------------------------------------------------------------------------------
# File dependencies
#-------------------------------------------------------------------------------
SRC = \
cdotc.f daxpy.f dcabs1.f dcopy.f ddot.f dgemm.f dgemv.f dger.f \
dnrm2.f drot.f dscal.f dspmv.f dspr2.f dswap.f dsymm.f dsymv.f \
dsyr2.f dsyr2k.f dsyrk.f dtrmm.f dtrmv.f dtrsm.f dtrsv.f dzasum.f \
dznrm2.f idamax.f izamax.f lsame.f zaxpy.f zcopy.f zdotc.f zdotu.f \
zdrot.f zdscal.f zgemm.f zgemv.f zgerc.f zgeru.f zhemm.f zhemv.f \
zher2.f zher2k.f zherk.f zhpmv.f zhpr2.f zhpr.f zscal.f zswap.f \
ztbsv.f ztpmv.f ztpsv.f ztrmm.f ztrmv.f ztrsm.f ztrsv.f
OBJ = $(SRC:.f=.o)
blas: $(OBJ)
$(AR) -rc blas.a $(OBJ)
clean:
rm -f *.o *.mod *~ *.a ifc* *.gcno gmon.out
ls:
ls -x --tabsize=0 --width=80 *.f
elk-7.2.42/src/BLAS/PaxHeaders.21776/zgemm.f 0000644 0000000 0000000 00000000132 14061636515 014731 x ustar 00 30 mtime=1623670093.020104251
30 atime=1623670093.019104252
30 ctime=1623670093.020104251
elk-7.2.42/src/BLAS/zgemm.f 0000644 0025044 0025044 00000033775 14061636515 017005 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEMM 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 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*16 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*16
*> 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*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
LOGICAL CONJA,CONJB,NOTA,NOTB
* ..
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+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, NCOLA and NROWB as the number of rows and columns of A
* and the number of rows of B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
CONJA = LSAME(TRANSA,'C')
CONJB = LSAME(TRANSB,'C')
IF (NOTA) THEN
NROWA = M
NCOLA = K
ELSE
NROWA = K
NCOLA = M
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('ZGEMM ',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 + DCONJG(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*DCONJG(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 + DCONJG(A(L,I))*DCONJG(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 + DCONJG(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)*DCONJG(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 ZGEMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ddot.f 0000644 0000000 0000000 00000000132 14061636515 014544 x ustar 00 30 mtime=1623670093.022104249
30 atime=1623670093.022104249
30 ctime=1623670093.022104249
elk-7.2.42/src/BLAS/ddot.f 0000644 0025044 0025044 00000006523 14061636515 016607 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DDOT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DDOT forms the dot product of two vectors.
*> uses unrolled loops for increments equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
DDOT = 0.0d0
DTEMP = 0.0d0
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,5)
IF (M.NE.0) THEN
DO I = 1,M
DTEMP = DTEMP + DX(I)*DY(I)
END DO
IF (N.LT.5) THEN
DDOT=DTEMP
RETURN
END IF
END IF
MP1 = M + 1
DO I = MP1,N,5
DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
$ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
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
DTEMP = DTEMP + DX(IX)*DY(IY)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
DDOT = DTEMP
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zgemv.f 0000644 0000000 0000000 00000000132 14061636515 014742 x ustar 00 30 mtime=1623670093.025104246
30 atime=1623670093.025104246
30 ctime=1623670093.025104246
elk-7.2.42/src/BLAS/zgemv.f 0000644 0025044 0025044 00000022240 14061636515 016777 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEMV 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 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*16 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*16
*> 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*16 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.
*> \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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 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 DCONJG,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('ZGEMV ',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 + DCONJG(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 + DCONJG(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 ZGEMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zhemv.f 0000644 0000000 0000000 00000000132 14061636515 014743 x ustar 00 30 mtime=1623670093.028104243
30 atime=1623670093.028104243
30 ctime=1623670093.028104243
elk-7.2.42/src/BLAS/zhemv.f 0000644 0025044 0025044 00000022554 14061636515 017010 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA,BETA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEMV 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the 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*16 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*16
*> 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*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 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 DBLE,DCONJG,MAX
* ..
*
* 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('ZHEMV ',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 + DCONJG(A(I,J))*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*DBLE(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 + DCONJG(A(I,J))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*DBLE(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*DBLE(A(J,J))
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + DCONJG(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*DBLE(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 + DCONJG(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 ZHEMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zaxpy.f 0000644 0000000 0000000 00000000132 14061636515 014765 x ustar 00 30 mtime=1623670093.031104241
30 atime=1623670093.031104241
30 ctime=1623670093.031104241
elk-7.2.42/src/BLAS/zaxpy.f 0000644 0025044 0025044 00000006004 14061636515 017022 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZAXPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY)
*
* .. Scalar Arguments ..
* COMPLEX*16 ZA
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*),ZY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZAXPY 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] ZA
*> \verbatim
*> ZA is COMPLEX*16
*> On entry, ZA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[in,out] ZY
*> \verbatim
*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of ZY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
COMPLEX*16 ZA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*),ZY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY
* ..
* .. External Functions ..
DOUBLE PRECISION DCABS1
EXTERNAL DCABS1
* ..
IF (N.LE.0) RETURN
IF (DCABS1(ZA).EQ.0.0d0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
ZY(I) = ZY(I) + ZA*ZX(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
ZY(IY) = ZY(IY) + ZA*ZX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
*
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/daxpy.f 0000644 0000000 0000000 00000000132 14061636515 014737 x ustar 00 30 mtime=1623670093.033104239
30 atime=1623670093.033104239
30 ctime=1623670093.033104239
elk-7.2.42/src/BLAS/daxpy.f 0000644 0025044 0025044 00000006645 14061636515 017007 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DAXPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION DA
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DAXPY constant times a vector plus a vector.
*> uses unrolled loops for increments equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DA
*> \verbatim
*> DA is DOUBLE PRECISION
*> On entry, DA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (DA.EQ.0.0d0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,4)
IF (M.NE.0) THEN
DO I = 1,M
DY(I) = DY(I) + DA*DX(I)
END DO
END IF
IF (N.LT.4) RETURN
MP1 = M + 1
DO I = MP1,N,4
DY(I) = DY(I) + DA*DX(I)
DY(I+1) = DY(I+1) + DA*DX(I+1)
DY(I+2) = DY(I+2) + DA*DX(I+2)
DY(I+3) = DY(I+3) + DA*DX(I+3)
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
DY(IY) = DY(IY) + DA*DX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zdotu.f 0000644 0000000 0000000 00000000132 14061636515 014757 x ustar 00 30 mtime=1623670093.035104237
30 atime=1623670093.035104237
30 ctime=1623670093.035104237
elk-7.2.42/src/BLAS/zdotu.f 0000644 0025044 0025044 00000005524 14061636515 017022 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZDOTU
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*),ZY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZDOTU forms the dot product of two complex vectors
*> ZDOTU = X^T * Y
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[in] ZY
*> \verbatim
*> ZY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of ZY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*),ZY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
COMPLEX*16 ZTEMP
INTEGER I,IX,IY
* ..
ZTEMP = (0.0d0,0.0d0)
ZDOTU = (0.0d0,0.0d0)
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
ZTEMP = ZTEMP + ZX(I)*ZY(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
ZTEMP = ZTEMP + ZX(IX)*ZY(IY)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
ZDOTU = ZTEMP
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zcopy.f 0000644 0000000 0000000 00000000132 14061636515 014756 x ustar 00 30 mtime=1623670093.036104236
30 atime=1623670093.036104236
30 ctime=1623670093.036104236
elk-7.2.42/src/BLAS/zcopy.f 0000644 0025044 0025044 00000005266 14061636515 017024 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*),ZY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZCOPY 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] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[out] ZY
*> \verbatim
*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of ZY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 4/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*),ZY(*)
* ..
*
* =====================================================================
*
* .. 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
ZY(I) = ZX(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
ZY(IY) = ZX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dscal.f 0000644 0000000 0000000 00000000132 14061636515 014700 x ustar 00 30 mtime=1623670093.038104234
30 atime=1623670093.038104234
30 ctime=1623670093.038104234
elk-7.2.42/src/BLAS/dscal.f 0000644 0025044 0025044 00000005664 14061636515 016750 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSCAL(N,DA,DX,INCX)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION DA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSCAL 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] DA
*> \verbatim
*> DA is DOUBLE PRECISION
*> On entry, DA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \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 DSCAL(N,DA,DX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,M,MP1,NINCX
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0 .OR. INCX.LE.0) 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
DX(I) = DA*DX(I)
END DO
IF (N.LT.5) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,5
DX(I) = DA*DX(I)
DX(I+1) = DA*DX(I+1)
DX(I+2) = DA*DX(I+2)
DX(I+3) = DA*DX(I+3)
DX(I+4) = DA*DX(I+4)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
DX(I) = DA*DX(I)
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/cdotc.f 0000644 0000000 0000000 00000000132 14061636515 014706 x ustar 00 30 mtime=1623670093.040104232
30 atime=1623670093.039104233
30 ctime=1623670093.040104232
elk-7.2.42/src/BLAS/cdotc.f 0000644 0025044 0025044 00000005622 14061636515 016750 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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 REAL 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 REAL 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.
*
*> \date November 2017
*
*> \ingroup complex_blas_level1
*
*> \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 (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. 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
elk-7.2.42/src/BLAS/PaxHeaders.21776/dznrm2.f 0000644 0000000 0000000 00000000132 14061636515 015026 x ustar 00 30 mtime=1623670093.041104231
30 atime=1623670093.041104231
30 ctime=1623670093.041104231
elk-7.2.42/src/BLAS/dznrm2.f 0000644 0025044 0025044 00000006464 14061636515 017075 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DZNRM2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX*16 X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DZNRM2 returns the euclidean norm of a vector via the function
*> name, so that
*>
*> DZNRM2 := 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*16 array, dimension (N)
*> complex vector with N elements
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of X
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> -- This version written on 25-October-1982.
*> Modified on 14-October-1993 to inline the call to ZLASSQ.
*> Sven Hammarling, Nag Ltd.
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX*16 X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION NORM,SCALE,SSQ,TEMP
INTEGER IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS,DBLE,DIMAG,SQRT
* ..
IF (N.LT.1 .OR. INCX.LT.1) THEN
NORM = ZERO
ELSE
SCALE = ZERO
SSQ = ONE
* The following loop is equivalent to this call to the LAPACK
* auxiliary routine:
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
*
DO 10 IX = 1,1 + (N-1)*INCX,INCX
IF (DBLE(X(IX)).NE.ZERO) THEN
TEMP = ABS(DBLE(X(IX)))
IF (SCALE.LT.TEMP) THEN
SSQ = ONE + SSQ* (SCALE/TEMP)**2
SCALE = TEMP
ELSE
SSQ = SSQ + (TEMP/SCALE)**2
END IF
END IF
IF (DIMAG(X(IX)).NE.ZERO) THEN
TEMP = ABS(DIMAG(X(IX)))
IF (SCALE.LT.TEMP) THEN
SSQ = ONE + SSQ* (SCALE/TEMP)**2
SCALE = TEMP
ELSE
SSQ = SSQ + (TEMP/SCALE)**2
END IF
END IF
10 CONTINUE
NORM = SCALE*SQRT(SSQ)
END IF
*
DZNRM2 = NORM
RETURN
*
* End of DZNRM2.
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dnrm2.f 0000644 0000000 0000000 00000000127 14061636515 014640 x ustar 00 29 mtime=1623670093.04310423
29 atime=1623670093.04210423
29 ctime=1623670093.04310423
elk-7.2.42/src/BLAS/dnrm2.f 0000644 0025044 0025044 00000006001 14061636515 016666 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DNRM2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DNRM2 returns the euclidean norm of a vector via the function
*> name, so that
*>
*> DNRM2 := 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 DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> -- This version written on 25-October-1982.
*> Modified on 14-October-1993 to inline the call to DLASSQ.
*> Sven Hammarling, Nag Ltd.
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
INTEGER IX
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS,SQRT
* ..
IF (N.LT.1 .OR. INCX.LT.1) THEN
NORM = ZERO
ELSE IF (N.EQ.1) THEN
NORM = ABS(X(1))
ELSE
SCALE = ZERO
SSQ = ONE
* The following loop is equivalent to this call to the LAPACK
* auxiliary routine:
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
*
DO 10 IX = 1,1 + (N-1)*INCX,INCX
IF (X(IX).NE.ZERO) THEN
ABSXI = ABS(X(IX))
IF (SCALE.LT.ABSXI) THEN
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
SCALE = ABSXI
ELSE
SSQ = SSQ + (ABSXI/SCALE)**2
END IF
END IF
10 CONTINUE
NORM = SCALE*SQRT(SSQ)
END IF
*
DNRM2 = NORM
RETURN
*
* End of DNRM2.
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dcopy.f 0000644 0000000 0000000 00000000132 14061636515 014730 x ustar 00 30 mtime=1623670093.044104228
30 atime=1623670093.044104228
30 ctime=1623670093.044104228
elk-7.2.42/src/BLAS/dcopy.f 0000644 0025044 0025044 00000006323 14061636515 016771 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCOPY 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] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. 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
DY(I) = DX(I)
END DO
IF (N.LT.7) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,7
DY(I) = DX(I)
DY(I+1) = DX(I+1)
DY(I+2) = DX(I+2)
DY(I+3) = DX(I+3)
DY(I+4) = DX(I+4)
DY(I+5) = DX(I+5)
DY(I+6) = DX(I+6)
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
DY(IY) = DX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dgemm.f 0000644 0000000 0000000 00000000132 14061636515 014703 x ustar 00 30 mtime=1623670093.046104227
30 atime=1623670093.045104228
30 ctime=1623670093.046104227
elk-7.2.42/src/BLAS/dgemm.f 0000644 0025044 0025044 00000025557 14061636515 016756 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEMM 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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
LOGICAL NOTA,NOTB
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Set NOTA and NOTB as true if A and B respectively are not
* transposed and set NROWA, NCOLA and NROWB as the number of rows
* and columns of A and the number of rows of B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
IF (NOTA) THEN
NROWA = M
NCOLA = K
ELSE
NROWA = K
NCOLA = M
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('DGEMM ',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 DGEMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/lsame.f 0000644 0000000 0000000 00000000132 14061636515 014713 x ustar 00 30 mtime=1623670093.047104226
30 atime=1623670093.047104226
30 ctime=1623670093.047104226
elk-7.2.42/src/BLAS/lsame.f 0000644 0025044 0025044 00000006101 14061636515 016746 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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.
*
*> \date December 2016
*
*> \ingroup aux_blas
*
* =====================================================================
LOGICAL FUNCTION LSAME(CA,CB)
*
* -- Reference BLAS level1 routine (version 3.1) --
* -- Reference BLAS 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 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
elk-7.2.42/src/BLAS/PaxHeaders.21776/drot.f 0000644 0000000 0000000 00000000132 14061636515 014562 x ustar 00 30 mtime=1623670093.049104224
30 atime=1623670093.049104224
30 ctime=1623670093.049104224
elk-7.2.42/src/BLAS/drot.f 0000644 0025044 0025044 00000006140 14061636515 016620 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DROT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION C,S
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DROT applies a plane rotation.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
DOUBLE PRECISION C,S
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
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
DTEMP = C*DX(I) + S*DY(I)
DY(I) = C*DY(I) - S*DX(I)
DX(I) = DTEMP
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
DTEMP = C*DX(IX) + S*DY(IY)
DY(IY) = C*DY(IY) - S*DX(IX)
DX(IX) = DTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dswap.f 0000644 0000000 0000000 00000000132 14061636515 014730 x ustar 00 30 mtime=1623670093.050104223
30 atime=1623670093.050104223
30 ctime=1623670093.050104223
elk-7.2.42/src/BLAS/dswap.f 0000644 0025044 0025044 00000006605 14061636515 016774 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSWAP
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSWAP 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] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
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
DTEMP = DX(I)
DX(I) = DY(I)
DY(I) = DTEMP
END DO
IF (N.LT.3) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,3
DTEMP = DX(I)
DX(I) = DY(I)
DY(I) = DTEMP
DTEMP = DX(I+1)
DX(I+1) = DY(I+1)
DY(I+1) = DTEMP
DTEMP = DX(I+2)
DX(I+2) = DY(I+2)
DY(I+2) = DTEMP
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
DTEMP = DX(IX)
DX(IX) = DY(IY)
DY(IY) = DTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/idamax.f 0000644 0000000 0000000 00000000132 14061636515 015055 x ustar 00 30 mtime=1623670093.052104221
30 atime=1623670093.052104221
30 ctime=1623670093.052104221
elk-7.2.42/src/BLAS/idamax.f 0000644 0025044 0025044 00000005343 14061636515 017117 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b IDAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IDAMAX 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] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup aux_blas
*
*> \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 IDAMAX(N,DX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DMAX
INTEGER I,IX
* ..
* .. Intrinsic Functions ..
INTRINSIC DABS
* ..
IDAMAX = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
IDAMAX = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DMAX = DABS(DX(1))
DO I = 2,N
IF (DABS(DX(I)).GT.DMAX) THEN
IDAMAX = I
DMAX = DABS(DX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
DMAX = DABS(DX(1))
IX = IX + INCX
DO I = 2,N
IF (DABS(DX(IX)).GT.DMAX) THEN
IDAMAX = I
DMAX = DABS(DX(IX))
END IF
IX = IX + INCX
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dtrsm.f 0000644 0000000 0000000 00000000127 14061636515 014747 x ustar 00 29 mtime=1623670093.05310422
29 atime=1623670093.05310422
29 ctime=1623670093.05310422
elk-7.2.42/src/BLAS/dtrsm.f 0000644 0025044 0025044 00000032734 14061636515 017011 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRSM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRSM solves one of the matrix equations
*>
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, 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.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) appears on the left
*> or right of X as follows:
*>
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
*>
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
*> \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**T.
*> \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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION array, dimension ( LDA, k ),
*> where k is m when SIDE = 'L' or 'l'
*> and k 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 DOUBLE PRECISION array, dimension ( LDB, N )
*> Before entry, the leading m by n part of the array B must
*> contain the right-hand side matrix B, and on exit is
*> overwritten by the solution matrix X.
*> \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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOUNIT,UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Test the input parameters.
*
LSIDE = LSAME(SIDE,'L')
IF (LSIDE) THEN
NROWA = M
ELSE
NROWA = N
END IF
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('DTRSM ',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*inv( A )*B.
*
IF (UPPER) THEN
DO 60 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 30 I = 1,M
B(I,J) = ALPHA*B(I,J)
30 CONTINUE
END IF
DO 50 K = M,1,-1
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 40 I = 1,K - 1
B(I,J) = B(I,J) - B(K,J)*A(I,K)
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
ELSE
DO 100 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 70 I = 1,M
B(I,J) = ALPHA*B(I,J)
70 CONTINUE
END IF
DO 90 K = 1,M
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 80 I = K + 1,M
B(I,J) = B(I,J) - B(K,J)*A(I,K)
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form B := alpha*inv( A**T )*B.
*
IF (UPPER) THEN
DO 130 J = 1,N
DO 120 I = 1,M
TEMP = ALPHA*B(I,J)
DO 110 K = 1,I - 1
TEMP = TEMP - A(K,I)*B(K,J)
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
B(I,J) = TEMP
120 CONTINUE
130 CONTINUE
ELSE
DO 160 J = 1,N
DO 150 I = M,1,-1
TEMP = ALPHA*B(I,J)
DO 140 K = I + 1,M
TEMP = TEMP - A(K,I)*B(K,J)
140 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
B(I,J) = TEMP
150 CONTINUE
160 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*inv( A ).
*
IF (UPPER) THEN
DO 210 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 170 I = 1,M
B(I,J) = ALPHA*B(I,J)
170 CONTINUE
END IF
DO 190 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
DO 180 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
180 CONTINUE
END IF
190 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 200 I = 1,M
B(I,J) = TEMP*B(I,J)
200 CONTINUE
END IF
210 CONTINUE
ELSE
DO 260 J = N,1,-1
IF (ALPHA.NE.ONE) THEN
DO 220 I = 1,M
B(I,J) = ALPHA*B(I,J)
220 CONTINUE
END IF
DO 240 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
DO 230 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
230 CONTINUE
END IF
240 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 250 I = 1,M
B(I,J) = TEMP*B(I,J)
250 CONTINUE
END IF
260 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*inv( A**T ).
*
IF (UPPER) THEN
DO 310 K = N,1,-1
IF (NOUNIT) THEN
TEMP = ONE/A(K,K)
DO 270 I = 1,M
B(I,K) = TEMP*B(I,K)
270 CONTINUE
END IF
DO 290 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
TEMP = A(J,K)
DO 280 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
280 CONTINUE
END IF
290 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 300 I = 1,M
B(I,K) = ALPHA*B(I,K)
300 CONTINUE
END IF
310 CONTINUE
ELSE
DO 360 K = 1,N
IF (NOUNIT) THEN
TEMP = ONE/A(K,K)
DO 320 I = 1,M
B(I,K) = TEMP*B(I,K)
320 CONTINUE
END IF
DO 340 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
TEMP = A(J,K)
DO 330 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
330 CONTINUE
END IF
340 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 350 I = 1,M
B(I,K) = ALPHA*B(I,K)
350 CONTINUE
END IF
360 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRSM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dgemv.f 0000644 0000000 0000000 00000000132 14061636515 014714 x ustar 00 30 mtime=1623670093.055104218
30 atime=1623670093.055104218
30 ctime=1623670093.055104218
elk-7.2.42/src/BLAS/dgemv.f 0000644 0025044 0025044 00000021073 14061636515 016754 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEMV 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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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.
*> \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.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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('DGEMV ',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 DGEMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dtrmm.f 0000644 0000000 0000000 00000000132 14061636515 014735 x ustar 00 30 mtime=1623670093.057104216
30 atime=1623670093.057104216
30 ctime=1623670093.057104216
elk-7.2.42/src/BLAS/dtrmm.f 0000644 0025044 0025044 00000031007 14061636515 016773 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRMM 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.
*> \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**T.
*> \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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOUNIT,UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Test the input parameters.
*
LSIDE = LSAME(SIDE,'L')
IF (LSIDE) THEN
NROWA = M
ELSE
NROWA = N
END IF
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('DTRMM ',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.
*
IF (UPPER) THEN
DO 110 J = 1,N
DO 100 I = M,1,-1
TEMP = B(I,J)
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 90 K = 1,I - 1
TEMP = TEMP + A(K,I)*B(K,J)
90 CONTINUE
B(I,J) = ALPHA*TEMP
100 CONTINUE
110 CONTINUE
ELSE
DO 140 J = 1,N
DO 130 I = 1,M
TEMP = B(I,J)
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 120 K = I + 1,M
TEMP = TEMP + A(K,I)*B(K,J)
120 CONTINUE
B(I,J) = ALPHA*TEMP
130 CONTINUE
140 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*A.
*
IF (UPPER) THEN
DO 180 J = N,1,-1
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 150 I = 1,M
B(I,J) = TEMP*B(I,J)
150 CONTINUE
DO 170 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 160 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
ELSE
DO 220 J = 1,N
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 190 I = 1,M
B(I,J) = TEMP*B(I,J)
190 CONTINUE
DO 210 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 200 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
200 CONTINUE
END IF
210 CONTINUE
220 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*A**T.
*
IF (UPPER) THEN
DO 260 K = 1,N
DO 240 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
TEMP = ALPHA*A(J,K)
DO 230 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
230 CONTINUE
END IF
240 CONTINUE
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(K,K)
IF (TEMP.NE.ONE) THEN
DO 250 I = 1,M
B(I,K) = TEMP*B(I,K)
250 CONTINUE
END IF
260 CONTINUE
ELSE
DO 300 K = N,1,-1
DO 280 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
TEMP = ALPHA*A(J,K)
DO 270 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
270 CONTINUE
END IF
280 CONTINUE
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(K,K)
IF (TEMP.NE.ONE) THEN
DO 290 I = 1,M
B(I,K) = TEMP*B(I,K)
290 CONTINUE
END IF
300 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dger.f 0000644 0000000 0000000 00000000132 14061636515 014533 x ustar 00 30 mtime=1623670093.059104215
30 atime=1623670093.058104216
30 ctime=1623670093.059104215
elk-7.2.42/src/BLAS/dger.f 0000644 0025044 0025044 00000013075 14061636515 016576 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGER performs the rank 1 operation
*>
*> A := alpha*x*y**T + 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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC 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('DGER ',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*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*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 DGER .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dtrmv.f 0000644 0000000 0000000 00000000132 14061636515 014746 x ustar 00 30 mtime=1623670093.060104214
30 atime=1623670093.060104214
30 ctime=1623670093.060104214
elk-7.2.42/src/BLAS/dtrmv.f 0000644 0025044 0025044 00000023620 14061636515 017006 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**T*x.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 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 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. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x. On exit, X is overwritten with the
*> transformed 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTRMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := A*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*A(I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 I = 1,J - 1
X(IX) = X(IX) + TEMP*A(I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*A(I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
60 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 70 I = N,J + 1,-1
X(IX) = X(IX) + TEMP*A(I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
JX = JX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A**T*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100 J = N,1,-1
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 90 I = J - 1,1,-1
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 120 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 110 I = J - 1,1,-1
IX = IX - INCX
TEMP = TEMP + A(I,J)*X(IX)
110 CONTINUE
X(JX) = TEMP
JX = JX - INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = 1,N
TEMP = X(J)
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 130 I = J + 1,N
TEMP = TEMP + A(I,J)*X(I)
130 CONTINUE
X(J) = TEMP
140 CONTINUE
ELSE
JX = KX
DO 160 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 150 I = J + 1,N
IX = IX + INCX
TEMP = TEMP + A(I,J)*X(IX)
150 CONTINUE
X(JX) = TEMP
JX = JX + INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dsymv.f 0000644 0000000 0000000 00000000132 14061636515 014754 x ustar 00 30 mtime=1623670093.062104212
30 atime=1623670093.062104212
30 ctime=1623670093.062104212
elk-7.2.42/src/BLAS/dsymv.f 0000644 0025044 0025044 00000022265 14061636515 017020 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYMV performs the matrix-vector operation
*>
*> y := alpha*A*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are n element vectors and
*> A is an n by n symmetric matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the array A is to be referenced as
*> follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of A
*> is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of A
*> is to be referenced.
*> \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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the symmetric matrix and the strictly
*> lower triangular part of A is not referenced.
*> Before entry with UPLO = 'L' or 'l', the leading n by n
*> lower triangular part of the array A must contain the lower
*> triangular part of the symmetric matrix and the strictly
*> upper triangular part of A is not referenced.
*> \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 DOUBLE PRECISION 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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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 MAX
* ..
*
* 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('DSYMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when A is stored in upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 I = 1,J - 1
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(J,J)
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(J,J)
IX = JX
IY = JY
DO 110 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dsyrk.f 0000644 0000000 0000000 00000000130 14061636515 014744 x ustar 00 29 mtime=1623670093.06410421
30 atime=1623670093.063104211
29 ctime=1623670093.06410421
elk-7.2.42/src/BLAS/dsyrk.f 0000644 0025044 0025044 00000025056 14061636515 017013 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYRK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYRK performs one of the symmetric rank k operations
*>
*> C := alpha*A*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*A + beta*C,
*>
*> where alpha and beta are scalars, C is an n by n symmetric matrix
*> and A is an n by k matrix in the first case and a k by n matrix
*> 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*A**T + beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**T*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 matrix A, and on entry with
*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
*> of rows of the matrix A. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION 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 symmetric 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 symmetric 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.
*> \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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+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,'T')) .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 (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYRK ',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.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
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.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
DO 70 I = J,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*A**T + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**T*A + beta*C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP = ZERO
DO 220 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYRK .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dspmv.f 0000644 0000000 0000000 00000000132 14061636515 014743 x ustar 00 30 mtime=1623670093.066104208
30 atime=1623670093.065104209
30 ctime=1623670093.066104208
elk-7.2.42/src/BLAS/dspmv.f 0000644 0025044 0025044 00000022372 14061636515 017006 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSPMV performs the matrix-vector operation
*>
*> y := alpha*A*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are n element vectors and
*> A is an n by n symmetric matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is DOUBLE PRECISION array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 6
ELSE IF (INCY.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
K = KK
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*AP(KK)
K = KK + 1
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
KK = KK + (N-J+1)
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*AP(KK)
IX = JX
IY = JY
DO 110 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + (N-J+1)
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dspr2.f 0000644 0000000 0000000 00000000132 14061636515 014644 x ustar 00 30 mtime=1623670093.067104207
30 atime=1623670093.067104207
30 ctime=1623670093.067104207
elk-7.2.42/src/BLAS/dspr2.f 0000644 0025044 0025044 00000020646 14061636515 016711 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSPR2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSPR2 performs the symmetric rank 2 operation
*>
*> A := alpha*x*y**T + alpha*y*x**T + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an
*> n by n symmetric matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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] AP
*> \verbatim
*> AP is DOUBLE PRECISION array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the symmetric matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
*
* 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
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSPR2 ',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 the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 10 I = 1,J
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
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*Y(J)
TEMP2 = ALPHA*X(J)
K = KK
DO 50 I = J,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSPR2 .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dsyr2.f 0000644 0000000 0000000 00000000132 14061636515 014655 x ustar 00 30 mtime=1623670093.069104205
30 atime=1623670093.069104205
30 ctime=1623670093.069104205
elk-7.2.42/src/BLAS/dsyr2.f 0000644 0025044 0025044 00000020622 14061636515 016714 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYR2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYR2 performs the symmetric rank 2 operation
*>
*> A := alpha*x*y**T + alpha*y*x**T + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an n
*> by n symmetric matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the array A is to be referenced as
*> follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of A
*> is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of A
*> is to be referenced.
*> \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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the symmetric matrix and the strictly
*> lower triangular part of A is not referenced. On exit, the
*> upper triangular part of the array A is overwritten by the
*> upper triangular part of the updated matrix.
*> Before entry with UPLO = 'L' or 'l', the leading n by n
*> lower triangular part of the array A must contain the lower
*> triangular part of the symmetric matrix and the strictly
*> upper triangular part of A is not referenced. On exit, the
*> lower triangular part of the array A is overwritten by the
*> lower triangular part of the updated matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level2
*
*> \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 DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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 MAX
* ..
*
* 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('DSYR2 ',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*Y(J)
TEMP2 = ALPHA*X(J)
DO 10 I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
END IF
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30 I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
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*Y(J)
TEMP2 = ALPHA*X(J)
DO 50 I = J,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
END IF
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70 I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYR2 .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dtrsv.f 0000644 0000000 0000000 00000000132 14061636515 014754 x ustar 00 30 mtime=1623670093.071104203
30 atime=1623670093.071104203
30 ctime=1623670093.071104203
elk-7.2.42/src/BLAS/dtrsv.f 0000644 0025044 0025044 00000023614 14061636515 017017 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b,
*>
*> where b and x are n element vectors and A is an n by n unit, or
*> non-unit, upper or lower triangular matrix.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**T*x = b.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 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 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. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element right-hand side vector b. On exit, X is overwritten
*> with the solution 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.
*>
*> 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup double_blas_level1
*
* =====================================================================
SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level1 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTRSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
DO 130 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRSV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dsymm.f 0000644 0000000 0000000 00000000132 14061636515 014743 x ustar 00 30 mtime=1623670093.073104202
30 atime=1623670093.072104203
30 ctime=1623670093.073104202
elk-7.2.42/src/BLAS/dsymm.f 0000644 0025044 0025044 00000025655 14061636515 017015 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER LDA,LDB,LDC,M,N
* CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYMM performs one of the matrix-matrix operations
*>
*> C := alpha*A*B + beta*C,
*>
*> or
*>
*> C := alpha*B*A + beta*C,
*>
*> where alpha and beta are scalars, A is a symmetric matrix and B and
*> C are m by n matrices.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether the symmetric matrix A
*> appears on the left or right in the operation as follows:
*>
*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
*>
*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the symmetric matrix A is to be
*> referenced as follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of the
*> symmetric matrix is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of the
*> symmetric matrix is to be referenced.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows 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 C.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is
*> m when SIDE = 'L' or 'l' and is n otherwise.
*> Before entry with SIDE = 'L' or 'l', the m by m part of
*> the array A must contain the symmetric matrix, such that
*> when UPLO = 'U' or 'u', the leading m by m upper triangular
*> part of the array A must contain the upper triangular part
*> of the symmetric matrix and the strictly lower triangular
*> part of A is not referenced, and when UPLO = 'L' or 'l',
*> the leading m by m lower triangular part of the array A
*> must contain the lower triangular part of the symmetric
*> matrix and the strictly upper triangular part of A is not
*> referenced.
*> Before entry with SIDE = 'R' or 'r', the n by n part of
*> the array A must contain the symmetric matrix, such that
*> when UPLO = 'U' or 'u', the leading n by n upper triangular
*> part of the array A must contain the upper triangular part
*> of the symmetric matrix and the strictly lower triangular
*> part of A is not referenced, and when UPLO = 'L' or 'l',
*> the leading n by n lower triangular part of the array A
*> must contain the lower triangular part of the symmetric
*> matrix and the strictly upper triangular part of A is not
*> referenced.
*> \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 ), otherwise LDA must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension ( LDB, N )
*> Before entry, the leading m 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. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> 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 DOUBLE PRECISION 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 updated
*> matrix.
*> \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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DSYMM ',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
*
* 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 (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*A(J,J)
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*A(J,K)
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*A(J,K)
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of DSYMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/dsyr2k.f 0000644 0000000 0000000 00000000126 14061636515 015033 x ustar 00 28 mtime=1623670093.0751042
30 atime=1623670093.074104201
28 ctime=1623670093.0751042
elk-7.2.42/src/BLAS/dsyr2k.f 0000644 0025044 0025044 00000030316 14061636515 017070 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYR2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYR2K performs one of the symmetric rank 2k operations
*>
*> C := alpha*A*B**T + alpha*B*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*B + alpha*B**T*A + beta*C,
*>
*> where alpha and beta are scalars, C is an n by n symmetric 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**T + alpha*B*A**T +
*> beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
*> beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*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 = 'T' or 't' or '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 DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION 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 symmetric 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 symmetric 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.
*> \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.
*
*> \date December 2016
*
*> \ingroup double_blas_level3
*
*> \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 DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+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,'T')) .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('DSYR2K',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.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
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.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
DO 70 I = J,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**T + alpha*B*A**T + C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**T*B + alpha*B**T*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 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
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 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of DSYR2K.
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zdrot.f 0000644 0000000 0000000 00000000132 14061636515 014754 x ustar 00 30 mtime=1623670093.076104199
30 atime=1623670093.076104199
30 ctime=1623670093.076104199
elk-7.2.42/src/BLAS/zdrot.f 0000644 0025044 0025044 00000007532 14061636515 017020 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZDROT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
*
* .. Scalar Arguments ..
* INTEGER INCX, INCY, N
* DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * ), CY( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> 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*16 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*16 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 DOUBLE PRECISION
*> On entry, C specifies the cosine, cos.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION
*> 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level1
*
* =====================================================================
SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
*
* -- Reference BLAS level1 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX, INCY, N
DOUBLE PRECISION C, S
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * ), CY( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY
COMPLEX*16 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
elk-7.2.42/src/BLAS/PaxHeaders.21776/zdscal.f 0000644 0000000 0000000 00000000132 14061636515 015072 x ustar 00 30 mtime=1623670093.078104197
30 atime=1623670093.078104197
30 ctime=1623670093.078104197
elk-7.2.42/src/BLAS/zdscal.f 0000644 0025044 0025044 00000005044 14061636515 017132 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZDSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZDSCAL(N,DA,ZX,INCX)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION DA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZDSCAL 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] DA
*> \verbatim
*> DA is DOUBLE PRECISION
*> On entry, DA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZDSCAL(N,DA,ZX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,NINCX
* ..
* .. Intrinsic Functions ..
INTRINSIC DCMPLX
* ..
IF (N.LE.0 .OR. INCX.LE.0) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DO I = 1,N
ZX(I) = DCMPLX(DA,0.0d0)*ZX(I)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
ZX(I) = DCMPLX(DA,0.0d0)*ZX(I)
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zswap.f 0000644 0000000 0000000 00000000132 14061636515 014756 x ustar 00 30 mtime=1623670093.079104196
30 atime=1623670093.079104196
30 ctime=1623670093.079104196
elk-7.2.42/src/BLAS/zswap.f 0000644 0025044 0025044 00000005450 14061636515 017017 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZSWAP
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*),ZY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSWAP interchanges two vectors.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*>
*> \param[in,out] ZY
*> \verbatim
*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of ZY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*),ZY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
COMPLEX*16 ZTEMP
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
ZTEMP = ZX(I)
ZX(I) = ZY(I)
ZY(I) = ZTEMP
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
ZTEMP = ZX(IX)
ZX(IX) = ZY(IY)
ZY(IY) = ZTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/izamax.f 0000644 0000000 0000000 00000000132 14061636515 015103 x ustar 00 30 mtime=1623670093.081104194
30 atime=1623670093.081104194
30 ctime=1623670093.081104194
elk-7.2.42/src/BLAS/izamax.f 0000644 0025044 0025044 00000005364 14061636515 017150 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b IZAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION IZAMAX(N,ZX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)|
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup aux_blas
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 1/15/85.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION IZAMAX(N,ZX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DMAX
INTEGER I,IX
* ..
* .. External Functions ..
DOUBLE PRECISION DCABS1
EXTERNAL DCABS1
* ..
IZAMAX = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
IZAMAX = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DMAX = DCABS1(ZX(1))
DO I = 2,N
IF (DCABS1(ZX(I)).GT.DMAX) THEN
IZAMAX = I
DMAX = DCABS1(ZX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
DMAX = DCABS1(ZX(1))
IX = IX + INCX
DO I = 2,N
IF (DCABS1(ZX(IX)).GT.DMAX) THEN
IZAMAX = I
DMAX = DCABS1(ZX(IX))
END IF
IX = IX + INCX
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zscal.f 0000644 0000000 0000000 00000000132 14061636515 014726 x ustar 00 30 mtime=1623670093.082104193
30 atime=1623670093.082104193
30 ctime=1623670093.082104193
elk-7.2.42/src/BLAS/zscal.f 0000644 0025044 0025044 00000004662 14061636515 016773 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
*
* .. Scalar Arguments ..
* COMPLEX*16 ZA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX*16 ZX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSCAL 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] ZA
*> \verbatim
*> ZA is COMPLEX*16
*> On entry, ZA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] ZX
*> \verbatim
*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of ZX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
*
* -- Reference BLAS level1 routine (version 3.8.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
COMPLEX*16 ZA
INTEGER INCX,N
* ..
* .. Array Arguments ..
COMPLEX*16 ZX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,NINCX
* ..
IF (N.LE.0 .OR. INCX.LE.0) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DO I = 1,N
ZX(I) = ZA*ZX(I)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
ZX(I) = ZA*ZX(I)
END DO
END IF
RETURN
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zgeru.f 0000644 0000000 0000000 00000000132 14061636515 014746 x ustar 00 30 mtime=1623670093.084104191
30 atime=1623670093.084104191
30 ctime=1623670093.084104191
elk-7.2.42/src/BLAS/zgeru.f 0000644 0025044 0025044 00000013020 14061636515 016777 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGERU
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGERU performs the rank 1 operation
*>
*> A := alpha*x*y**T + 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 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*16 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*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC 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('ZGERU ',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*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*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 ZGERU .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztrsm.f 0000644 0000000 0000000 00000000132 14061636515 014771 x ustar 00 30 mtime=1623670093.085104191
30 atime=1623670093.085104191
30 ctime=1623670093.085104191
elk-7.2.42/src/BLAS/ztrsm.f 0000644 0025044 0025044 00000035747 14061636515 017046 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRSM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSM solves one of the matrix equations
*>
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, 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.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) appears on the left
*> or right of X as follows:
*>
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
*>
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
*> \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*16
*> 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*16 array, dimension ( LDA, k ),
*> where k is m when SIDE = 'L' or 'l'
*> and k 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*16 array, dimension ( LDB, N )
*> Before entry, the leading m by n part of the array B must
*> contain the right-hand side matrix B, and on exit is
*> overwritten by the solution matrix X.
*> \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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
* ..
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+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('ZTRSM ',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*inv( A )*B.
*
IF (UPPER) THEN
DO 60 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 30 I = 1,M
B(I,J) = ALPHA*B(I,J)
30 CONTINUE
END IF
DO 50 K = M,1,-1
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 40 I = 1,K - 1
B(I,J) = B(I,J) - B(K,J)*A(I,K)
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
ELSE
DO 100 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 70 I = 1,M
B(I,J) = ALPHA*B(I,J)
70 CONTINUE
END IF
DO 90 K = 1,M
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 80 I = K + 1,M
B(I,J) = B(I,J) - B(K,J)*A(I,K)
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form B := alpha*inv( A**T )*B
* or B := alpha*inv( A**H )*B.
*
IF (UPPER) THEN
DO 140 J = 1,N
DO 130 I = 1,M
TEMP = ALPHA*B(I,J)
IF (NOCONJ) THEN
DO 110 K = 1,I - 1
TEMP = TEMP - A(K,I)*B(K,J)
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
ELSE
DO 120 K = 1,I - 1
TEMP = TEMP - DCONJG(A(K,I))*B(K,J)
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I))
END IF
B(I,J) = TEMP
130 CONTINUE
140 CONTINUE
ELSE
DO 180 J = 1,N
DO 170 I = M,1,-1
TEMP = ALPHA*B(I,J)
IF (NOCONJ) THEN
DO 150 K = I + 1,M
TEMP = TEMP - A(K,I)*B(K,J)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
ELSE
DO 160 K = I + 1,M
TEMP = TEMP - DCONJG(A(K,I))*B(K,J)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(I,I))
END IF
B(I,J) = TEMP
170 CONTINUE
180 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*inv( A ).
*
IF (UPPER) THEN
DO 230 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 190 I = 1,M
B(I,J) = ALPHA*B(I,J)
190 CONTINUE
END IF
DO 210 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
DO 200 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
200 CONTINUE
END IF
210 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 220 I = 1,M
B(I,J) = TEMP*B(I,J)
220 CONTINUE
END IF
230 CONTINUE
ELSE
DO 280 J = N,1,-1
IF (ALPHA.NE.ONE) THEN
DO 240 I = 1,M
B(I,J) = ALPHA*B(I,J)
240 CONTINUE
END IF
DO 260 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
DO 250 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
250 CONTINUE
END IF
260 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 270 I = 1,M
B(I,J) = TEMP*B(I,J)
270 CONTINUE
END IF
280 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*inv( A**T )
* or B := alpha*B*inv( A**H ).
*
IF (UPPER) THEN
DO 330 K = N,1,-1
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = ONE/A(K,K)
ELSE
TEMP = ONE/DCONJG(A(K,K))
END IF
DO 290 I = 1,M
B(I,K) = TEMP*B(I,K)
290 CONTINUE
END IF
DO 310 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = A(J,K)
ELSE
TEMP = DCONJG(A(J,K))
END IF
DO 300 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
300 CONTINUE
END IF
310 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 320 I = 1,M
B(I,K) = ALPHA*B(I,K)
320 CONTINUE
END IF
330 CONTINUE
ELSE
DO 380 K = 1,N
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = ONE/A(K,K)
ELSE
TEMP = ONE/DCONJG(A(K,K))
END IF
DO 340 I = 1,M
B(I,K) = TEMP*B(I,K)
340 CONTINUE
END IF
DO 360 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = A(J,K)
ELSE
TEMP = DCONJG(A(J,K))
END IF
DO 350 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
350 CONTINUE
END IF
360 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 370 I = 1,M
B(I,K) = ALPHA*B(I,K)
370 CONTINUE
END IF
380 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTRSM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztbsv.f 0000644 0000000 0000000 00000000132 14061636515 014762 x ustar 00 30 mtime=1623670093.087104189
30 atime=1623670093.087104189
30 ctime=1623670093.087104189
elk-7.2.42/src/BLAS/ztbsv.f 0000644 0025044 0025044 00000033516 14061636515 017027 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTBSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,K,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTBSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*x = b,
*>
*> where b and x are n element vectors and A is an n by n unit, or
*> non-unit, upper or lower triangular band matrix, with ( k + 1 )
*> diagonals.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with UPLO = 'U' or 'u', K specifies the number of
*> super-diagonals of the matrix A.
*> On entry with UPLO = 'L' or 'l', K specifies the number of
*> sub-diagonals of the matrix A.
*> K must satisfy 0 .le. K.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
*> by n part of the array A must contain the upper triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row
*> ( k + 1 ) of the array, the first super-diagonal starting at
*> position 2 in row k, and so on. The top left k by k triangle
*> of the array A is not referenced.
*> The following program segment will transfer an upper
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = K + 1 - J
*> DO 10, I = MAX( 1, J - K ), J
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
*> by n part of the array A must contain the lower triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row 1 of
*> the array, the first sub-diagonal starting at position 1 in
*> row 2, and so on. The bottom right k by k triangle of the
*> array A is not referenced.
*> The following program segment will transfer a lower
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = 1 - J
*> DO 10, I = J, MIN( N, J + K )
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Note that when DIAG = 'U' or 'u' the elements of the array A
*> corresponding to the diagonal elements of the matrix are not
*> referenced, 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. LDA must be at least
*> ( k + 1 ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element right-hand side vector b. On exit, X is overwritten
*> with the solution 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZTBSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed by sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
L = KPLUS1 - J
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
TEMP = X(J)
DO 10 I = J - 1,MAX(1,J-K),-1
X(I) = X(I) - TEMP*A(L+I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 40 J = N,1,-1
KX = KX - INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = KPLUS1 - J
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
TEMP = X(JX)
DO 30 I = J - 1,MAX(1,J-K),-1
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX - INCX
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
L = 1 - J
IF (NOUNIT) X(J) = X(J)/A(1,J)
TEMP = X(J)
DO 50 I = J + 1,MIN(N,J+K)
X(I) = X(I) - TEMP*A(L+I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
KX = KX + INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = 1 - J
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
TEMP = X(JX)
DO 70 I = J + 1,MIN(N,J+K)
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
L = KPLUS1 - J
IF (NOCONJ) THEN
DO 90 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
ELSE
DO 100 I = MAX(1,J-K),J - 1
TEMP = TEMP - DCONJG(A(L+I,J))*X(I)
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J))
END IF
X(J) = TEMP
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
IF (NOCONJ) THEN
DO 120 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
ELSE
DO 130 I = MAX(1,J-K),J - 1
TEMP = TEMP - DCONJG(A(L+I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J))
END IF
X(JX) = TEMP
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
L = 1 - J
IF (NOCONJ) THEN
DO 150 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(I)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
ELSE
DO 160 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - DCONJG(A(L+I,J))*X(I)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J))
END IF
X(J) = TEMP
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
TEMP = X(JX)
IX = KX
L = 1 - J
IF (NOCONJ) THEN
DO 180 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
ELSE
DO 190 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - DCONJG(A(L+I,J))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J))
END IF
X(JX) = TEMP
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTBSV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztrmm.f 0000644 0000000 0000000 00000000132 14061636515 014763 x ustar 00 30 mtime=1623670093.089104187
30 atime=1623670093.089104187
30 ctime=1623670093.089104187
elk-7.2.42/src/BLAS/ztrmm.f 0000644 0025044 0025044 00000034166 14061636515 017032 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRMM 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*16
*> 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*16 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*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
* ..
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+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('ZTRMM ',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*DCONJG(A(I,I))
DO 100 K = 1,I - 1
TEMP = TEMP + DCONJG(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*DCONJG(A(I,I))
DO 140 K = I + 1,M
TEMP = TEMP + DCONJG(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*DCONJG(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*DCONJG(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*DCONJG(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*DCONJG(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 ZTRMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zher2.f 0000644 0000000 0000000 00000000132 14061636515 014644 x ustar 00 30 mtime=1623670093.091104185
30 atime=1623670093.091104185
30 ctime=1623670093.091104185
elk-7.2.42/src/BLAS/zher2.f 0000644 0025044 0025044 00000022451 14061636515 016705 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHER2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHER2 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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \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*16 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*16 array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular part of the 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 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 DBLE,DCONJG,MAX
* ..
*
* 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('ZHER2 ',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*DCONJG(Y(J))
TEMP2 = DCONJG(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) = DBLE(A(J,J)) +
+ DBLE(X(J)*TEMP1+Y(J)*TEMP2)
ELSE
A(J,J) = DBLE(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*DCONJG(Y(JY))
TEMP2 = DCONJG(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) = DBLE(A(J,J)) +
+ DBLE(X(JX)*TEMP1+Y(JY)*TEMP2)
ELSE
A(J,J) = DBLE(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*DCONJG(Y(J))
TEMP2 = DCONJG(ALPHA*X(J))
A(J,J) = DBLE(A(J,J)) +
+ DBLE(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) = DBLE(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*DCONJG(Y(JY))
TEMP2 = DCONJG(ALPHA*X(JX))
A(J,J) = DBLE(A(J,J)) +
+ DBLE(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) = DBLE(A(J,J))
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHER2 .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztrsv.f 0000644 0000000 0000000 00000000132 14061636515 015002 x ustar 00 30 mtime=1623670093.093104183
30 atime=1623670093.093104183
30 ctime=1623670093.093104183
elk-7.2.42/src/BLAS/ztrsv.f 0000644 0025044 0025044 00000026615 14061636515 017051 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*x = b,
*>
*> where b and x are n element vectors and A is an n by n unit, or
*> non-unit, upper or lower triangular matrix.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular 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 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. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element right-hand side vector b. On exit, X is overwritten
*> with the solution 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZTRSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
IF (NOCONJ) THEN
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 100 I = 1,J - 1
TEMP = TEMP - DCONJG(A(I,J))*X(I)
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J))
END IF
X(J) = TEMP
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
IX = KX
TEMP = X(JX)
IF (NOCONJ) THEN
DO 120 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 130 I = 1,J - 1
TEMP = TEMP - DCONJG(A(I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J))
END IF
X(JX) = TEMP
JX = JX + INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
IF (NOCONJ) THEN
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 160 I = N,J + 1,-1
TEMP = TEMP - DCONJG(A(I,J))*X(I)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J))
END IF
X(J) = TEMP
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
IX = KX
TEMP = X(JX)
IF (NOCONJ) THEN
DO 180 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 190 I = N,J + 1,-1
TEMP = TEMP - DCONJG(A(I,J))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J))
END IF
X(JX) = TEMP
JX = JX - INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTRSV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztrmv.f 0000644 0000000 0000000 00000000132 14061636515 014774 x ustar 00 30 mtime=1623670093.095104181
30 atime=1623670093.094104182
30 ctime=1623670093.095104181
elk-7.2.42/src/BLAS/ztrmv.f 0000644 0025044 0025044 00000026467 14061636515 017050 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, N ).
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular 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 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. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x. On exit, X is overwritten with the
*> transformed 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG,MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZTRMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := A*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*A(I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 I = 1,J - 1
X(IX) = X(IX) + TEMP*A(I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*A(I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
60 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 70 I = N,J + 1,-1
X(IX) = X(IX) + TEMP*A(I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
JX = JX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A**T*x or x := A**H*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 110 J = N,1,-1
TEMP = X(J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 90 I = J - 1,1,-1
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
DO 100 I = J - 1,1,-1
TEMP = TEMP + DCONJG(A(I,J))*X(I)
100 CONTINUE
END IF
X(J) = TEMP
110 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 140 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 120 I = J - 1,1,-1
IX = IX - INCX
TEMP = TEMP + A(I,J)*X(IX)
120 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
DO 130 I = J - 1,1,-1
IX = IX - INCX
TEMP = TEMP + DCONJG(A(I,J))*X(IX)
130 CONTINUE
END IF
X(JX) = TEMP
JX = JX - INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = 1,N
TEMP = X(J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 150 I = J + 1,N
TEMP = TEMP + A(I,J)*X(I)
150 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
DO 160 I = J + 1,N
TEMP = TEMP + DCONJG(A(I,J))*X(I)
160 CONTINUE
END IF
X(J) = TEMP
170 CONTINUE
ELSE
JX = KX
DO 200 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 180 I = J + 1,N
IX = IX + INCX
TEMP = TEMP + A(I,J)*X(IX)
180 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
DO 190 I = J + 1,N
IX = IX + INCX
TEMP = TEMP + DCONJG(A(I,J))*X(IX)
190 CONTINUE
END IF
X(JX) = TEMP
JX = JX + INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTRMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zhemm.f 0000644 0000000 0000000 00000000131 14061636515 014731 x ustar 00 30 mtime=1623670093.097104179
29 atime=1623670093.09610418
30 ctime=1623670093.097104179
elk-7.2.42/src/BLAS/zhemm.f 0000644 0025044 0025044 00000026153 14061636515 016776 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA,BETA
* INTEGER LDA,LDB,LDC,M,N
* CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEMM performs one of the matrix-matrix operations
*>
*> C := alpha*A*B + beta*C,
*>
*> or
*>
*> C := alpha*B*A + beta*C,
*>
*> where alpha and beta are scalars, A is an hermitian matrix and B and
*> C are m by n matrices.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether the hermitian matrix A
*> appears on the left or right in the operation as follows:
*>
*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
*>
*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the hermitian matrix A is to be
*> referenced as follows:
*>
*> UPLO = 'U' or 'u' Only the upper triangular part of the
*> hermitian matrix is to be referenced.
*>
*> UPLO = 'L' or 'l' Only the lower triangular part of the
*> hermitian matrix is to be referenced.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows 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 C.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is
*> m when SIDE = 'L' or 'l' and is n otherwise.
*> Before entry with SIDE = 'L' or 'l', the m by m part of
*> the array A must contain the hermitian matrix, such that
*> when UPLO = 'U' or 'u', the leading m by m 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, and when UPLO = 'L' or 'l',
*> the leading m by m 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.
*> Before entry with SIDE = 'R' or 'r', the n by n part of
*> the array A must contain the hermitian matrix, such that
*> when 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, and when 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, they 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. When SIDE = 'L' or 'l' then
*> LDA must be at least max( 1, m ), otherwise LDA must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX*16 array, dimension ( LDB, N )
*> Before entry, the leading m 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. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX*16
*> 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*16 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 updated
*> matrix.
*> \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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHEMM ',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
*
* 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 (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*DCONJG(A(K,I))
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*DBLE(A(I,I)) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*DCONJG(A(K,I))
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*DBLE(A(I,I)) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*DBLE(A(J,J))
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*DCONJG(A(J,K))
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*DCONJG(A(J,K))
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of ZHEMM .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zher2k.f 0000644 0000000 0000000 00000000132 14061636515 015017 x ustar 00 30 mtime=1623670093.098104178
30 atime=1623670093.098104178
30 ctime=1623670093.098104178
elk-7.2.42/src/BLAS/zher2k.f 0000644 0025044 0025044 00000034530 14061636515 017061 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHER2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* DOUBLE PRECISION BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHER2K 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*16 .
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 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*16 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 ).
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION .
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 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.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level3
*
*> \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 DBLE( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
DOUBLE PRECISION BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER (ONE=1.0D+0)
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+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('ZHER2K',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.DBLE(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*DBLE(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.DBLE(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*DBLE(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.DBLE(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*DBLE(C(J,J))
ELSE
C(J,J) = DBLE(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*DCONJG(B(J,L))
TEMP2 = DCONJG(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) = DBLE(C(J,J)) +
+ DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2)
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.DBLE(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*DBLE(C(J,J))
ELSE
C(J,J) = DBLE(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*DCONJG(B(J,L))
TEMP2 = DCONJG(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) = DBLE(C(J,J)) +
+ DBLE(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 + DCONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
190 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.DBLE(ZERO)) THEN
C(J,J) = DBLE(ALPHA*TEMP1+
+ DCONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*DBLE(C(J,J)) +
+ DBLE(ALPHA*TEMP1+
+ DCONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.DBLE(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ DCONJG(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 + DCONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
220 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.DBLE(ZERO)) THEN
C(J,J) = DBLE(ALPHA*TEMP1+
+ DCONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*DBLE(C(J,J)) +
+ DBLE(ALPHA*TEMP1+
+ DCONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.DBLE(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ DCONJG(ALPHA)*TEMP2
END IF
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHER2K.
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztpsv.f 0000644 0000000 0000000 00000000132 14061636515 015000 x ustar 00 30 mtime=1623670093.100104177
30 atime=1623670093.100104177
30 ctime=1623670093.100104177
elk-7.2.42/src/BLAS/ztpsv.f 0000644 0025044 0025044 00000030117 14061636515 017037 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTPSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTPSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*x = b,
*>
*> where b and x are n element vectors and A is an n by n unit, or
*> non-unit, upper or lower triangular matrix, supplied in packed form.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element right-hand side vector b. On exit, X is overwritten
*> with the solution 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZTPSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK - 1
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*AP(K)
K = K - 1
10 CONTINUE
END IF
KK = KK - J
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 30 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*AP(K)
30 CONTINUE
END IF
JX = JX - INCX
KK = KK - J
40 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK + 1
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*AP(K)
K = K + 1
50 CONTINUE
END IF
KK = KK + (N-J+1)
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
X(IX) = X(IX) - TEMP*AP(K)
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
K = KK
IF (NOCONJ) THEN
DO 90 I = 1,J - 1
TEMP = TEMP - AP(K)*X(I)
K = K + 1
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
ELSE
DO 100 I = 1,J - 1
TEMP = TEMP - DCONJG(AP(K))*X(I)
K = K + 1
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1))
END IF
X(J) = TEMP
KK = KK + J
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
TEMP = X(JX)
IX = KX
IF (NOCONJ) THEN
DO 120 K = KK,KK + J - 2
TEMP = TEMP - AP(K)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
ELSE
DO 130 K = KK,KK + J - 2
TEMP = TEMP - DCONJG(AP(K))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK+J-1))
END IF
X(JX) = TEMP
JX = JX + INCX
KK = KK + J
140 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
K = KK
IF (NOCONJ) THEN
DO 150 I = N,J + 1,-1
TEMP = TEMP - AP(K)*X(I)
K = K - 1
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
ELSE
DO 160 I = N,J + 1,-1
TEMP = TEMP - DCONJG(AP(K))*X(I)
K = K - 1
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J))
END IF
X(J) = TEMP
KK = KK - (N-J+1)
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
TEMP = X(JX)
IX = KX
IF (NOCONJ) THEN
DO 180 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - AP(K)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
ELSE
DO 190 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - DCONJG(AP(K))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/DCONJG(AP(KK-N+J))
END IF
X(JX) = TEMP
JX = JX - INCX
KK = KK - (N-J+1)
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTPSV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zhpmv.f 0000644 0000000 0000000 00000000132 14061636515 014756 x ustar 00 30 mtime=1623670093.102104175
30 atime=1623670093.102104175
30 ctime=1623670093.102104175
elk-7.2.42/src/BLAS/zhpmv.f 0000644 0025044 0025044 00000022752 14061636515 017023 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA,BETA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPMV 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, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \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*16
*> 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*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER (ONE= (1.0D+0,0.0D+0))
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 6
ELSE IF (INCY.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
K = KK
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK+J-1)) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*DBLE(AP(KK))
K = KK + 1
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + DCONJG(AP(K))*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
KK = KK + (N-J+1)
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*DBLE(AP(KK))
IX = JX
IY = JY
DO 110 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + DCONJG(AP(K))*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + (N-J+1)
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPMV .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/zhpr2.f 0000644 0000000 0000000 00000000132 14061636515 014657 x ustar 00 30 mtime=1623670093.104104173
30 atime=1623670093.103104174
30 ctime=1623670093.104104173
elk-7.2.42/src/BLAS/zhpr2.f 0000644 0025044 0025044 00000022636 14061636515 016725 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPR2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* .. Scalar Arguments ..
* COMPLEX*16 ALPHA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPR2 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, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \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*16
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \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*16 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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE,DCONJG
* ..
*
* 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
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZHPR2 ',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 the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*DCONJG(Y(J))
TEMP2 = DCONJG(ALPHA*X(J))
K = KK
DO 10 I = 1,J - 1
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
AP(KK+J-1) = DBLE(AP(KK+J-1)) +
+ DBLE(X(J)*TEMP1+Y(J)*TEMP2)
ELSE
AP(KK+J-1) = DBLE(AP(KK+J-1))
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*DCONJG(Y(JY))
TEMP2 = DCONJG(ALPHA*X(JX))
IX = KX
IY = KY
DO 30 K = KK,KK + J - 2
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
AP(KK+J-1) = DBLE(AP(KK+J-1)) +
+ DBLE(X(JX)*TEMP1+Y(JY)*TEMP2)
ELSE
AP(KK+J-1) = DBLE(AP(KK+J-1))
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
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*DCONJG(Y(J))
TEMP2 = DCONJG(ALPHA*X(J))
AP(KK) = DBLE(AP(KK)) +
+ DBLE(X(J)*TEMP1+Y(J)*TEMP2)
K = KK + 1
DO 50 I = J + 1,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
ELSE
AP(KK) = DBLE(AP(KK))
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*DCONJG(Y(JY))
TEMP2 = DCONJG(ALPHA*X(JX))
AP(KK) = DBLE(AP(KK)) +
+ DBLE(X(JX)*TEMP1+Y(JY)*TEMP2)
IX = JX
IY = JY
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
70 CONTINUE
ELSE
AP(KK) = DBLE(AP(KK))
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPR2 .
*
END
elk-7.2.42/src/BLAS/PaxHeaders.21776/ztpmv.f 0000644 0000000 0000000 00000000132 14061636515 014772 x ustar 00 30 mtime=1623670093.106104171
30 atime=1623670093.105104172
30 ctime=1623670093.106104171
elk-7.2.42/src/BLAS/ztpmv.f 0000644 0025044 0025044 00000027752 14061636515 017044 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX*16 AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTPMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix 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] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \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] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x. On exit, X is overwritten with the
*> transformed 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
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level2
*
*> \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 ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* -- Reference BLAS level2 routine (version 3.7.0) --
* -- Reference BLAS 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 INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX*16 AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER (ZERO= (0.0D+0,0.0D+0))
* ..
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('ZTPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x:= A*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*AP(K)
K = K + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 K = KK,KK + J - 2
X(IX) = X(IX) + TEMP*AP(K)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*AP(K)
K = K - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
END IF
KK = KK - (N-J+1)
60 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 70 K = KK,KK - (N- (J+1)),-1
X(IX) = X(IX) + TEMP*AP(K)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
END IF
JX = JX - INCX
KK = KK - (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A**T*x or x := A**H*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 110 J = N,1,-1
TEMP = X(J)
K = KK - 1
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 90 I = J - 1,1,-1
TEMP = TEMP + AP(K)*X(I)
K = K - 1
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK))
DO 100 I = J - 1,1,-1
TEMP = TEMP + DCONJG(AP(K))*X(I)
K = K - 1
100 CONTINUE
END IF
X(J) = TEMP
KK = KK - J
110 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 140 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 120 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + AP(K)*X(IX)
120 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK))
DO 130 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + DCONJG(AP(K))*X(IX)
130 CONTINUE
END IF
X(JX) = TEMP
JX = JX - INCX
KK = KK - J
140 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 170 J = 1,N
TEMP = X(J)
K = KK + 1
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 150 I = J + 1,N
TEMP = TEMP + AP(K)*X(I)
K = K + 1
150 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK))
DO 160 I = J + 1,N
TEMP = TEMP + DCONJG(AP(K))*X(I)
K = K + 1
160 CONTINUE
END IF
X(J) = TEMP
KK = KK + (N-J+1)
170 CONTINUE
ELSE
JX = KX
DO 200 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 180 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + AP(K)*X(IX)
180 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*DCONJG(AP(KK))
DO 190 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + DCONJG(AP(K))*X(IX)
190 CONTINUE
END IF
X(JX) = TEMP
JX = JX + INCX
KK = KK + (N-J+1)
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZTPMV .
*
END
elk-7.2.42/src/PaxHeaders.21776/LAPACK 0000644 0000000 0000000 00000000132 14061636515 013600 x ustar 00 30 mtime=1623670093.464103839
30 atime=1623670093.112104166
30 ctime=1623670093.464103839
elk-7.2.42/src/LAPACK/ 0000755 0025044 0025044 00000000000 14061636515 015712 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaisnan.f 0000644 0000000 0000000 00000000132 14061636515 015615 x ustar 00 30 mtime=1623670093.113104164
30 atime=1623670093.113104164
30 ctime=1623670093.113104164
elk-7.2.42/src/LAPACK/dlaisnan.f 0000644 0025044 0025044 00000005060 14061636515 017653 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAISNAN 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 DLAISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This routine is not for general use. It exists solely to avoid
*> over-optimization in DISNAN.
*>
*> DLAISNAN 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] DIN1
*> \verbatim
*> DIN1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] DIN2
*> \verbatim
*> DIN2 is DOUBLE PRECISION
*> 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 DLAISNAN( DIN1, DIN2 )
*
* -- 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 ..
DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
* ..
*
* =====================================================================
*
* .. Executable Statements ..
DLAISNAN = (DIN1.NE.DIN2)
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/disnan.f 0000644 0000000 0000000 00000000132 14061636515 015300 x ustar 00 30 mtime=1623670093.115104163
30 atime=1623670093.115104163
30 ctime=1623670093.115104163
elk-7.2.42/src/LAPACK/disnan.f 0000644 0025044 0025044 00000003727 14061636515 017346 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DISNAN tests input for NaN.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION DISNAN( DIN )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION, INTENT(IN) :: DIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DISNAN 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] DIN
*> \verbatim
*> DIN is DOUBLE PRECISION
*> 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 DISNAN( DIN )
*
* -- 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 ..
DOUBLE PRECISION, INTENT(IN) :: DIN
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL DLAISNAN
EXTERNAL DLAISNAN
* ..
* .. Executable Statements ..
DISNAN = DLAISNAN(DIN,DIN)
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsyev.f 0000644 0000000 0000000 00000000132 14061636515 015156 x ustar 00 30 mtime=1623670093.117104161
30 atime=1623670093.116104162
30 ctime=1623670093.117104161
elk-7.2.42/src/LAPACK/dsyev.f 0000644 0025044 0025044 00000020364 14061636515 017220 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYEV computes all eigenvalues and, optionally, eigenvectors of a
*> real symmetric matrix A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
*> orthonormal eigenvectors of the matrix A.
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
*> or the upper triangle (if UPLO='U') of A, including the
*> diagonal, is destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,3*N-1).
*> For optimal efficiency, LWORK >= (NB+2)*N,
*> where NB is the blocksize for DSYTRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the algorithm failed to converge; i
*> off-diagonal elements of an intermediate tridiagonal
*> form did not converge to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYeigen
*
* =====================================================================
SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
$ LLWORK, LWKOPT, NB
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB+2 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
$ INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 2
IF( WANTZ )
$ A( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
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 DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDE = 1
INDTAU = INDE + N
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* DORGTR to generate the orthogonal matrix, then call DSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, WORK( INDE ), INFO )
ELSE
CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
$ LLWORK, IINFO )
CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
$ INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYEV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsygvx.f 0000644 0000000 0000000 00000000131 14061636515 015347 x ustar 00 30 mtime=1623670093.119104159
29 atime=1623670093.11810416
30 ctime=1623670093.119104159
elk-7.2.42/src/LAPACK/dsygvx.f 0000644 0025044 0025044 00000035561 14061636515 017417 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYGVX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYGVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
* VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
* LWORK, IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYGVX computes selected eigenvalues, and optionally, eigenvectors
*> of a real generalized symmetric-definite eigenproblem, of the form
*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
*> and B are assumed to be symmetric and B is also positive definite.
*> Eigenvalues and eigenvectors can be selected by specifying either a
*> range of values or a range of indices for the desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> Specifies the problem type to be solved:
*> = 1: A*x = (lambda)*B*x
*> = 2: A*B*x = (lambda)*x
*> = 3: B*A*x = (lambda)*x
*> \endverbatim
*>
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found.
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found.
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A and B are stored;
*> = 'L': Lower triangle of A and B are stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix pencil (A,B). N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*>
*> 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[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, N)
*> On entry, the symmetric matrix B. If UPLO = 'U', the
*> leading N-by-N upper triangular part of B contains the
*> upper triangular part of the matrix B. If UPLO = 'L',
*> the leading N-by-N lower triangular part of B contains
*> the lower triangular part of the matrix B.
*>
*> On exit, if INFO <= N, the part of B containing the matrix is
*> overwritten by the triangular factor U or L from the Cholesky
*> factorization B = U**T*U or B = L*L**T.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing C to tridiagonal form, where C is the symmetric
*> matrix of the standard symmetric problem to which the
*> generalized problem is transformed.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> On normal exit, the first M elements contain the selected
*> eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M))
*> If JOBZ = 'N', then Z is not referenced.
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> The eigenvectors are normalized as follows:
*> if ITYPE = 1 or 2, Z**T*B*Z = I;
*> if ITYPE = 3, Z**T*inv(B)*Z = I.
*>
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and the
*> index of the eigenvector is returned in IFAIL.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,8*N).
*> For optimal efficiency, LWORK >= (NB+3)*N,
*> where NB is the blocksize for DSYTRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: DPOTRF or DSYEVX returned an error code:
*> <= N: if INFO = i, DSYEVX failed to converge;
*> i eigenvectors failed to converge. Their indices
*> are stored in array IFAIL.
*> > N: if INFO = N + i, for 1 <= i <= N, then the leading
*> minor of order i of B is not positive definite.
*> The factorization of B could not be completed and
*> no eigenvalues or eigenvectors were computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleSYeigen
*
*> \par Contributors:
* ==================
*>
*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
$ LWORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER LWKMIN, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
UPPER = LSAME( UPLO, 'U' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF (INFO.EQ.0) THEN
IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
INFO = -18
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
LWKMIN = MAX( 1, 8*N )
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
* Form a Cholesky factorization of B.
*
CALL DPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'T'
END IF
*
CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U**T*y
*
IF( UPPER ) THEN
TRANS = 'T'
ELSE
TRANS = 'N'
END IF
*
CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
$ LDB, Z, LDZ )
END IF
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYGVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlamch.f 0000644 0000000 0000000 00000000132 14061636515 015254 x ustar 00 30 mtime=1623670093.120104158
30 atime=1623670093.120104158
30 ctime=1623670093.120104158
elk-7.2.42/src/LAPACK/dlamch.f 0000644 0025044 0025044 00000006723 14061636515 017321 0 ustar 00dewhurst dewhurst 0000000 0000000 FUNCTION DLAMCH ( CMACH ) RESULT(RMACH)
!
! -- LAPACK auxiliary routine Replacement for DLAMCH.f
! use Fortran 90 Machine Parameter built-in functions.
!
character(len=1) :: CMACH
real(kind(1.d0)) :: xdbl, ydbl, RMACH
!
! Purpose
! =======
!
!
! DLAMCH determines double precision machine parameters.
!
! Arguments
! =========
!
! CMACH (input) CHARACTER*1
! Specifies the value to be returned by DLAMCH:
! = 'E' or 'e', DLAMCH := eps
! = 'S' or 's , DLAMCH := sfmin
! = 'B' or 'b', DLAMCH := base
! = 'P' or 'p', DLAMCH := eps*base
! = 'N' or 'n', DLAMCH := t
! = 'R' or 'r', DLAMCH := rnd
! = 'M' or 'm', DLAMCH := emin
! = 'U' or 'u', DLAMCH := rmin
! = 'L' or 'l', DLAMCH := emax
! = 'O' or 'o', DLAMCH := rmax
!
! where
!
!
! =====================================================================
xdbl=1.d0
IF( CMACH == 'E' .or. CMACH == 'e' ) THEN
! eps = relative machine precision
RMACH = Epsilon(xdbl)
ELSE IF( CMACH == 'S' .or. CMACH == 's' ) THEN
! sfmin = safe minimum, such that 1/sfmin does not overflow
RMACH = Tiny(xdbl)
ELSE IF( CMACH == 'B' .or. CMACH == 'b' ) THEN
! base = base of the machine
RMACH = Radix(xdbl)
ELSE IF( CMACH == 'P' .or. CMACH == 'p' ) THEN
! prec = eps*base
RMACH = Radix(xdbl)*Epsilon(xdbl)
ELSE IF( CMACH == 'N' .or. CMACH == 'n' ) THEN
! t = number of (base) digits in the mantissa
RMACH = Digits(xdbl)
ELSE IF( CMACH == 'R' .or. CMACH == 'r' ) THEN
! rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
! Assume rounding (IEEE).
RMACH = 1.0
ELSE IF( CMACH == 'M' .or. CMACH == 'm' ) THEN
! emin = minimum exponent before (gradual) underflow
RMACH = Minexponent(xdbl)
ELSE IF( CMACH == 'U' .or. CMACH == 'u' ) THEN
! rmin = underflow threshold - base**(emin-1)
RMACH = Tiny(xdbl)
ELSE IF( CMACH == 'L' .or. CMACH == 'l' ) THEN
! emax = largest exponent before overflow
RMACH = Maxexponent(xdbl)
ELSE IF( CMACH == 'O' .or. CMACH == 'o' ) THEN
! rmax = overflow threshold - (base**emax)*(1-eps)
RMACH = Huge(xdbl)
END IF
!
END
*
************************************************************************
*
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
*
* .. Local variables ..
INTEGER I
DOUBLE PRECISION X(10),Y(10)
* ..
*
* Purpose
* =======
*
* DLAMC3 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.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* B (input) DOUBLE PRECISION
* The values A and B.
*
* =====================================================================
*
* .. Executable Statements ..
*
* DLAMC3 = A + B
* Modification by JKD to ensure variables are flushed to memory
DO I=1,10
X(I)=A
END DO
DO I=1,10
Y(I)=X(I)+B
END DO
DLAMC3=Y(10)
*
RETURN
*
* End of DLAMC3
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhpgvx.f 0000644 0000000 0000000 00000000132 14061636515 015352 x ustar 00 30 mtime=1623670093.122104156
30 atime=1623670093.122104156
30 ctime=1623670093.122104156
elk-7.2.42/src/LAPACK/zhpgvx.f 0000644 0025044 0025044 00000032214 14061636515 017411 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPGVX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPGVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
* IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPGVX computes selected eigenvalues and, optionally, eigenvectors
*> of a complex generalized Hermitian-definite eigenproblem, of the form
*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
*> B are assumed to be Hermitian, stored in packed format, and B is also
*> positive definite. Eigenvalues and eigenvectors can be selected by
*> specifying either a range of values or a range of indices for the
*> desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> Specifies the problem type to be solved:
*> = 1: A*x = (lambda)*B*x
*> = 2: A*B*x = (lambda)*x
*> = 3: B*A*x = (lambda)*x
*> \endverbatim
*>
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found;
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found;
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangles of A and B are stored;
*> = 'L': Lower triangles of A and B are stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, the contents of AP are destroyed.
*> \endverbatim
*>
*> \param[in,out] BP
*> \verbatim
*> BP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> B, packed columnwise in a linear array. The j-th column of B
*> is stored in the array BP as follows:
*> if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
*> if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
*>
*> On exit, the triangular factor U or L from the Cholesky
*> factorization B = U**H*U or B = L*L**H, in the same storage
*> format as B.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*>
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*>
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*>
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*>
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing AP to tridiagonal form.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> On normal exit, the first M elements contain the selected
*> eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> If JOBZ = 'N', then Z is not referenced.
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> The eigenvectors are normalized as follows:
*> if ITYPE = 1 or 2, Z**H*B*Z = I;
*> if ITYPE = 3, Z**H*inv(B)*Z = I.
*>
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and the
*> index of the eigenvector is returned in IFAIL.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (7*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: ZPPTRF or ZHPEVX returned an error code:
*> <= N: if INFO = i, ZHPEVX failed to converge;
*> i eigenvectors failed to converge. Their indices
*> are stored in array IFAIL.
*> > N: if INFO = N + i, for 1 <= i <= n, then the leading
*> minor of order i of B is not positive definite.
*> The factorization of B could not be completed and
*> no eigenvalues or eigenvectors were computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHEReigen
*
*> \par Contributors:
* ==================
*>
*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
$ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL ) THEN
INFO = -9
END IF
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 ) THEN
INFO = -10
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -11
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -16
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPGVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL ZPPTRF( UPLO, N, BP, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
CALL ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
$ W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'C'
END IF
*
DO 10 J = 1, M
CALL ZTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
10 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U**H *y
*
IF( UPPER ) THEN
TRANS = 'C'
ELSE
TRANS = 'N'
END IF
*
DO 20 J = 1, M
CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
$ 1 )
20 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPGVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/iparam2stage.f 0000644 0000000 0000000 00000000132 14061636515 016403 x ustar 00 30 mtime=1623670093.124104154
30 atime=1623670093.124104154
30 ctime=1623670093.124104154
elk-7.2.42/src/LAPACK/iparam2stage.f 0000644 0025044 0025044 00000030004 14061636515 020435 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b IPARAM2STAGE
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download IPARAM2STAGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS,
* NI, NBI, IBI, NXI )
* #if defined(_OPENMP)
* use omp_lib
* #endif
* IMPLICIT NONE
*
* .. Scalar Arguments ..
* CHARACTER*( * ) NAME, OPTS
* INTEGER ISPEC, NI, NBI, IBI, NXI
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This program sets problem and machine dependent parameters
*> useful for xHETRD_2STAGE, xHETRD_HE2HB, xHETRD_HB2ST,
*> xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD
*> and related subroutines for eigenvalue problems.
*> It is called whenever ILAENV is called with 17 <= ISPEC <= 21.
*> It is called whenever ILAENV2STAGE is called with 1 <= ISPEC <= 5
*> with a direct conversion ISPEC + 16.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ISPEC
*> \verbatim
*> ISPEC is integer scalar
*> ISPEC specifies which tunable parameter IPARAM2STAGE should
*> return.
*>
*> ISPEC=17: the optimal blocksize nb for the reduction to
*> BAND
*>
*> ISPEC=18: the optimal blocksize ib for the eigenvectors
*> singular vectors update routine
*>
*> ISPEC=19: The length of the array that store the Housholder
*> representation for the second stage
*> Band to Tridiagonal or Bidiagonal
*>
*> ISPEC=20: The workspace needed for the routine in input.
*>
*> ISPEC=21: For future release.
*> \endverbatim
*>
*> \param[in] NAME
*> \verbatim
*> NAME is character string
*> Name of the calling subroutine
*> \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] NI
*> \verbatim
*> NI is INTEGER which is the size of the matrix
*> \endverbatim
*>
*> \param[in] NBI
*> \verbatim
*> NBI is INTEGER which is the used in the reduciton,
*> (e.g., the size of the band), needed to compute workspace
*> and LHOUS2.
*> \endverbatim
*>
*> \param[in] IBI
*> \verbatim
*> IBI is INTEGER which represent the IB of the reduciton,
*> needed to compute workspace and LHOUS2.
*> \endverbatim
*>
*> \param[in] NXI
*> \verbatim
*> NXI is INTEGER needed in the future release.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup auxOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Implemented by Azzam Haidar.
*>
*> All detail are available on technical report, SC11, SC13 papers.
*>
*> Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
*> Parallel reduction to condensed forms for symmetric eigenvalue problems
*> using aggregated fine-grained and memory-aware kernels. In Proceedings
*> of 2011 International Conference for High Performance Computing,
*> Networking, Storage and Analysis (SC '11), New York, NY, USA,
*> Article 8 , 11 pages.
*> http://doi.acm.org/10.1145/2063384.2063394
*>
*> A. Haidar, J. Kurzak, P. Luszczek, 2013.
*> An improved parallel singular value algorithm and its implementation
*> for multicore hardware, In Proceedings of 2013 International Conference
*> for High Performance Computing, Networking, Storage and Analysis (SC '13).
*> Denver, Colorado, USA, 2013.
*> Article 90, 12 pages.
*> http://doi.acm.org/10.1145/2503210.2503292
*>
*> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure
*> calculations based on fine-grained memory aware tasks.
*> International Journal of High Performance Computing Applications.
*> Volume 28 Issue 2, Pages 196-209, May 2014.
*> http://hpc.sagepub.com/content/28/2/196
*>
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS,
$ NI, NBI, IBI, NXI )
#if defined(_OPENMP)
use omp_lib
#endif
IMPLICIT NONE
*
* -- LAPACK auxiliary routine (version 3.8.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*( * ) NAME, OPTS
INTEGER ISPEC, NI, NBI, IBI, NXI
*
* ================================================================
* ..
* .. Local Scalars ..
INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS,
$ FACTOPTNB, QROPTNB, LQOPTNB
LOGICAL RPREC, CPREC
CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*1
* ..
* .. Intrinsic Functions ..
INTRINSIC CHAR, ICHAR, MAX
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Invalid value for ISPEC
*
IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN
IPARAM2STAGE = -1
RETURN
ENDIF
*
* Get the number of threads
*
NTHREADS = 1
#if defined(_OPENMP)
!$OMP PARALLEL
NTHREADS = OMP_GET_NUM_THREADS()
!$OMP END PARALLEL
#endif
* WRITE(*,*) 'IPARAM VOICI NTHREADS ISPEC ',NTHREADS, ISPEC
*
IF( ISPEC .NE. 19 ) THEN
*
* Convert NAME to upper case if the first character is lower case.
*
IPARAM2STAGE = -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 100 I = 2, 12
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
100 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 110 I = 2, 12
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 )
110 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 120 I = 2, 12
IC = ICHAR( SUBNAM( I: I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I: I ) = CHAR( IC-32 )
120 CONTINUE
END IF
END IF
*
PREC = SUBNAM( 1: 1 )
ALGO = SUBNAM( 4: 6 )
STAG = SUBNAM( 8:12 )
RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D'
CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z'
*
* Invalid value for PRECISION
*
IF( .NOT.( RPREC .OR. CPREC ) ) THEN
IPARAM2STAGE = -1
RETURN
ENDIF
ENDIF
* WRITE(*,*),'RPREC,CPREC ',RPREC,CPREC,
* $ ' ALGO ',ALGO,' STAGE ',STAG
*
*
IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN
*
* ISPEC = 17, 18: block size KD, IB
* Could be also dependent from N but for now it
* depend only on sequential or parallel
*
IF( NTHREADS.GT.4 ) THEN
IF( CPREC ) THEN
KD = 128
IB = 32
ELSE
KD = 160
IB = 40
ENDIF
ELSE IF( NTHREADS.GT.1 ) THEN
IF( CPREC ) THEN
KD = 64
IB = 32
ELSE
KD = 64
IB = 32
ENDIF
ELSE
IF( CPREC ) THEN
KD = 16
IB = 16
ELSE
KD = 32
IB = 16
ENDIF
ENDIF
IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD
IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB
*
ELSE IF ( ISPEC .EQ. 19 ) THEN
*
* ISPEC = 19:
* LHOUS length of the Houselholder representation
* matrix (V,T) of the second stage. should be >= 1.
*
* Will add the VECT OPTION HERE next release
VECT = OPTS(1:1)
IF( VECT.EQ.'N' ) THEN
LHOUS = MAX( 1, 4*NI )
ELSE
* This is not correct, it need to call the ALGO and the stage2
LHOUS = MAX( 1, 4*NI ) + IBI
ENDIF
IF( LHOUS.GE.0 ) THEN
IPARAM2STAGE = LHOUS
ELSE
IPARAM2STAGE = -1
ENDIF
*
ELSE IF ( ISPEC .EQ. 20 ) THEN
*
* ISPEC = 20: (21 for future use)
* LWORK length of the workspace for
* either or both stages for TRD and BRD. should be >= 1.
* TRD:
* TRD_stage 1: = LT + LW + LS1 + LS2
* = LDT*KD + N*KD + N*MAX(KD,FACTOPTNB) + LDS2*KD
* where LDT=LDS2=KD
* = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD
* TRD_stage 2: = (2NB+1)*N + KD*NTHREADS
* TRD_both : = max(stage1,stage2) + AB ( AB=(KD+1)*N )
* = N*KD + N*max(KD+1,FACTOPTNB)
* + max(2*KD*KD, KD*NTHREADS)
* + (KD+1)*N
LWORK = -1
SUBNAM(1:1) = PREC
SUBNAM(2:6) = 'GEQRF'
QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 )
SUBNAM(2:6) = 'GELQF'
LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 )
* Could be QR or LQ for TRD and the max for BRD
FACTOPTNB = MAX(QROPTNB, LQOPTNB)
IF( ALGO.EQ.'TRD' ) THEN
IF( STAG.EQ.'2STAG' ) THEN
LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB)
$ + MAX(2*NBI*NBI, NBI*NTHREADS)
$ + (NBI+1)*NI
ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN
LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI
ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN
LWORK = (2*NBI+1)*NI + NBI*NTHREADS
ENDIF
ELSE IF( ALGO.EQ.'BRD' ) THEN
IF( STAG.EQ.'2STAG' ) THEN
LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB)
$ + MAX(2*NBI*NBI, NBI*NTHREADS)
$ + (NBI+1)*NI
ELSE IF( STAG.EQ.'GE2GB' ) THEN
LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI
ELSE IF( STAG.EQ.'GB2BD' ) THEN
LWORK = (3*NBI+1)*NI + NBI*NTHREADS
ENDIF
ENDIF
LWORK = MAX ( 1, LWORK )
IF( LWORK.GT.0 ) THEN
IPARAM2STAGE = LWORK
ELSE
IPARAM2STAGE = -1
ENDIF
*
ELSE IF ( ISPEC .EQ. 21 ) THEN
*
* ISPEC = 21 for future use
IPARAM2STAGE = NXI
ENDIF
*
* ==== End of IPARAM2STAGE ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhegv.f 0000644 0000000 0000000 00000000132 14061636515 015147 x ustar 00 30 mtime=1623670093.126104152
30 atime=1623670093.126104152
30 ctime=1623670093.126104152
elk-7.2.42/src/LAPACK/zhegv.f 0000644 0025044 0025044 00000023067 14061636515 017214 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEGV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
* LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
*> of a complex generalized Hermitian-definite eigenproblem, of the form
*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
*> Here A and B are assumed to be Hermitian and B is also
*> positive definite.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> Specifies the problem type to be solved:
*> = 1: A*x = (lambda)*B*x
*> = 2: A*B*x = (lambda)*x
*> = 3: B*A*x = (lambda)*x
*> \endverbatim
*>
*> \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 triangles of A and B are stored;
*> = 'L': Lower triangles of A and B are stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the 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
*> matrix Z of eigenvectors. The eigenvectors are normalized
*> as follows:
*> if ITYPE = 1 or 2, Z**H*B*Z = I;
*> if ITYPE = 3, Z**H*inv(B)*Z = I.
*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
*> or the lower triangle (if UPLO='L') 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[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB, N)
*> On entry, the Hermitian positive definite matrix B.
*> If UPLO = 'U', the leading N-by-N upper triangular part of B
*> contains the upper triangular part of the matrix B.
*> If UPLO = 'L', the leading N-by-N lower triangular part of B
*> contains the lower triangular part of the matrix B.
*>
*> On exit, if INFO <= N, the part of B containing the matrix is
*> overwritten by the triangular factor U or L from the Cholesky
*> factorization B = U**H*U or B = L*L**H.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,2*N-1).
*> For optimal efficiency, LWORK >= (NB+1)*N,
*> where NB is the blocksize for ZHETRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: ZPOTRF or ZHEEV returned an error code:
*> <= N: if INFO = i, ZHEEV failed to converge;
*> i off-diagonal elements of an intermediate
*> tridiagonal form did not converge to zero;
*> > N: if INFO = N + i, for 1 <= i <= N, then the leading
*> minor of order i of B is not positive definite.
*> The factorization of B could not be completed and
*> no eigenvalues or eigenvectors were computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEeigen
*
* =====================================================================
SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
$ LWORK, RWORK, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER, WANTZ
CHARACTER TRANS
INTEGER LWKOPT, NB, NEIG
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHEEV, ZHEGST, ZPOTRF, ZTRMM, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB + 1 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 2*N - 1 ) .AND. .NOT.LQUERY ) THEN
INFO = -11
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEGV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form a Cholesky factorization of B.
*
CALL ZPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
NEIG = N
IF( INFO.GT.0 )
$ NEIG = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'C'
END IF
*
CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U**H *y
*
IF( UPPER ) THEN
TRANS = 'C'
ELSE
TRANS = 'N'
END IF
*
CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
$ B, LDB, A, LDA )
END IF
END IF
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZHEGV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dgesv.f 0000644 0000000 0000000 00000000132 14061636515 015134 x ustar 00 30 mtime=1623670093.128104151
30 atime=1623670093.127104151
30 ctime=1623670093.128104151
elk-7.2.42/src/LAPACK/dgesv.f 0000644 0025044 0025044 00000012027 14061636515 017173 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DGESV computes the solution to system of linear equations A * X = B for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGESV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGESV computes the solution to a real system of linear equations
*> A * X = B,
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as
*> A = P * L * U,
*> where P is a permutation matrix, L is unit lower triangular, and U is
*> upper triangular. The factored form of A is then used to solve the
*> system of equations A * X = B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the N-by-N coefficient matrix A.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices that define the permutation matrix P;
*> row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS matrix of right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEsolve
*
* =====================================================================
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL DGETRF, DGETRS, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of A.
*
CALL DGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* End of DGESV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhegvx.f 0000644 0000000 0000000 00000000127 14061636515 015343 x ustar 00 29 mtime=1623670093.12910415
29 atime=1623670093.12910415
29 ctime=1623670093.12910415
elk-7.2.42/src/LAPACK/zhegvx.f 0000644 0025044 0025044 00000036064 14061636515 017405 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEGVX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEGVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
* VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
* LWORK, RWORK, IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
* $ Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEGVX computes selected eigenvalues, and optionally, eigenvectors
*> of a complex generalized Hermitian-definite eigenproblem, of the form
*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
*> B are assumed to be Hermitian and B is also positive definite.
*> Eigenvalues and eigenvectors can be selected by specifying either a
*> range of values or a range of indices for the desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> Specifies the problem type to be solved:
*> = 1: A*x = (lambda)*B*x
*> = 2: A*B*x = (lambda)*x
*> = 3: B*A*x = (lambda)*x
*> \endverbatim
*>
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found.
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found.
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangles of A and B are stored;
*> = 'L': Lower triangles of A and B are stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the 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, 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[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB, N)
*> On entry, the Hermitian matrix B. If UPLO = 'U', the
*> leading N-by-N upper triangular part of B contains the
*> upper triangular part of the matrix B. If UPLO = 'L',
*> the leading N-by-N lower triangular part of B contains
*> the lower triangular part of the matrix B.
*>
*> On exit, if INFO <= N, the part of B containing the matrix is
*> overwritten by the triangular factor U or L from the Cholesky
*> factorization B = U**H*U or B = L*L**H.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*>
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*>
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*>
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*>
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing C to tridiagonal form, where C is the symmetric
*> matrix of the standard symmetric problem to which the
*> generalized problem is transformed.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> The first M elements contain the selected
*> eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M))
*> If JOBZ = 'N', then Z is not referenced.
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> The eigenvectors are normalized as follows:
*> if ITYPE = 1 or 2, Z**T*B*Z = I;
*> if ITYPE = 3, Z**T*inv(B)*Z = I.
*>
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and the
*> index of the eigenvector is returned in IFAIL.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,2*N).
*> For optimal efficiency, LWORK >= (NB+1)*N,
*> where NB is the blocksize for ZHETRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (7*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: ZPOTRF or ZHEEVX returned an error code:
*> <= N: if INFO = i, ZHEEVX failed to converge;
*> i eigenvectors failed to converge. Their indices
*> are stored in array IFAIL.
*> > N: if INFO = N + i, for 1 <= i <= N, then the leading
*> minor of order i of B is not positive definite.
*> The factorization of B could not be completed and
*> no eigenvalues or eigenvectors were computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16HEeigen
*
*> \par Contributors:
* ==================
*>
*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
$ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
$ LWORK, RWORK, IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
$ Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
CHARACTER TRANS
INTEGER LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHEEVX, ZHEGST, ZPOTRF, ZTRMM, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
UPPER = LSAME( UPLO, 'U' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -2
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -3
ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -11
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -12
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -13
END IF
END IF
END IF
IF (INFO.EQ.0) THEN
IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
INFO = -18
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB + 1 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
INFO = -20
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEGVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
* Form a Cholesky factorization of B.
*
CALL ZPOTRF( UPLO, N, B, LDB, INFO )
IF( INFO.NE.0 ) THEN
INFO = N + INFO
RETURN
END IF
*
* Transform problem to standard eigenvalue problem and solve.
*
CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
CALL ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
$ M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL,
$ INFO )
*
IF( WANTZ ) THEN
*
* Backtransform eigenvectors to the original problem.
*
IF( INFO.GT.0 )
$ M = INFO - 1
IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
*
* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y
*
IF( UPPER ) THEN
TRANS = 'N'
ELSE
TRANS = 'C'
END IF
*
CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
$ LDB, Z, LDZ )
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* For B*A*x=(lambda)*x;
* backtransform eigenvectors: x = L*y or U**H *y
*
IF( UPPER ) THEN
TRANS = 'C'
ELSE
TRANS = 'N'
END IF
*
CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
$ LDB, Z, LDZ )
END IF
END IF
*
* Set WORK(1) to optimal complex workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZHEGVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgeev.f 0000644 0000000 0000000 00000000132 14061636515 015144 x ustar 00 30 mtime=1623670093.131104148
30 atime=1623670093.131104148
30 ctime=1623670093.131104148
elk-7.2.42/src/LAPACK/zgeev.f 0000644 0025044 0025044 00000037276 14061636515 017220 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
* WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBVL, JOBVR
* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
*> eigenvalues and, optionally, the left and/or right eigenvectors.
*>
*> The right eigenvector v(j) of A satisfies
*> A * v(j) = lambda(j) * v(j)
*> where lambda(j) is its eigenvalue.
*> The left eigenvector u(j) of A satisfies
*> u(j)**H * A = lambda(j) * u(j)**H
*> where u(j)**H denotes the conjugate transpose of u(j).
*>
*> The computed eigenvectors are normalized to have Euclidean norm
*> equal to 1 and largest component real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBVL
*> \verbatim
*> JOBVL is CHARACTER*1
*> = 'N': left eigenvectors of A are not computed;
*> = 'V': left eigenvectors of are computed.
*> \endverbatim
*>
*> \param[in] JOBVR
*> \verbatim
*> JOBVR is CHARACTER*1
*> = 'N': right eigenvectors of A are not computed;
*> = 'V': right eigenvectors of A are computed.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N matrix A.
*> On exit, A has been overwritten.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> W contains the computed eigenvalues.
*> \endverbatim
*>
*> \param[out] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,N)
*> If JOBVL = 'V', the left eigenvectors u(j) are stored one
*> after another in the columns of VL, in the same order
*> as their eigenvalues.
*> If JOBVL = 'N', VL is not referenced.
*> u(j) = VL(:,j), the j-th column of VL.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the array VL. LDVL >= 1; if
*> JOBVL = 'V', LDVL >= N.
*> \endverbatim
*>
*> \param[out] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,N)
*> If JOBVR = 'V', the right eigenvectors v(j) are stored one
*> after another in the columns of VR, in the same order
*> as their eigenvalues.
*> If JOBVR = 'N', VR is not referenced.
*> v(j) = VR(:,j), the j-th column of VR.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR. LDVR >= 1; if
*> JOBVR = 'V', LDVR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,2*N).
*> For good performance, LWORK must generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if INFO = i, the QR algorithm failed to compute all the
*> eigenvalues, and no eigenvectors have been computed;
*> elements i+1:N of W contain eigenvalues which have
*> converged.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
* @precisions fortran z -> c
*
*> \ingroup complex16GEeigen
*
* =====================================================================
SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
$ WORK, LWORK, RWORK, INFO )
implicit none
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBVL, JOBVR
INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * )
COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
$ W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
CHARACTER SIDE
INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
$ IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT
DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
COMPLEX*16 TMP
* ..
* .. Local Arrays ..
LOGICAL SELECT( 1 )
DOUBLE PRECISION DUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
$ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZUNGHR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, ILAENV
DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE
EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
WANTVL = LSAME( JOBVL, 'V' )
WANTVR = LSAME( JOBVR, 'V' )
IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
INFO = -1
ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
INFO = -10
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* CWorkspace refers to complex workspace, and RWorkspace to real
* workspace. NB refers to the optimal block size for the
* immediately following subroutine, as returned by ILAENV.
* HSWORK refers to the workspace preferred by ZHSEQR, as
* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
* the worst case.)
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
ELSE
MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
MINWRK = 2*N
IF( WANTVL ) THEN
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
$ WORK, -1, INFO )
ELSE IF( WANTVR ) THEN
MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
$ ' ', N, 1, N, -1 ) )
CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA,
$ VL, LDVL, VR, LDVR,
$ N, NOUT, WORK, -1, RWORK, -1, IERR )
LWORK_TREVC = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, N + LWORK_TREVC )
CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
$ WORK, -1, INFO )
ELSE
CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
$ WORK, -1, INFO )
END IF
HSWORK = INT( WORK(1) )
MAXWRK = MAX( MAXWRK, HSWORK, MINWRK )
END IF
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SQRT( SMLNUM ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
SCALEA = .FALSE.
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
SCALEA = .TRUE.
CSCALE = SMLNUM
ELSE IF( ANRM.GT.BIGNUM ) THEN
SCALEA = .TRUE.
CSCALE = BIGNUM
END IF
IF( SCALEA )
$ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
*
* Balance the matrix
* (CWorkspace: none)
* (RWorkspace: need N)
*
IBAL = 1
CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
*
* Reduce to upper Hessenberg form
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: none)
*
ITAU = 1
IWRK = ITAU + N
CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
IF( WANTVL ) THEN
*
* Want left eigenvectors
* Copy Householder vectors to VL
*
SIDE = 'L'
CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL )
*
* Generate unitary matrix in VL
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VL
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
IF( WANTVR ) THEN
*
* Want left and right eigenvectors
* Copy Schur vectors to VR
*
SIDE = 'B'
CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
END IF
*
ELSE IF( WANTVR ) THEN
*
* Want right eigenvectors
* Copy Householder vectors to VR
*
SIDE = 'R'
CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR )
*
* Generate unitary matrix in VR
* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
* (RWorkspace: none)
*
CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
$ LWORK-IWRK+1, IERR )
*
* Perform QR iteration, accumulating Schur vectors in VR
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
*
ELSE
*
* Compute eigenvalues only
* (CWorkspace: need 1, prefer HSWORK (see comments) )
* (RWorkspace: none)
*
IWRK = ITAU
CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
$ WORK( IWRK ), LWORK-IWRK+1, INFO )
END IF
*
* If INFO .NE. 0 from ZHSEQR, then quit
*
IF( INFO.NE.0 )
$ GO TO 50
*
IF( WANTVL .OR. WANTVR ) THEN
*
* Compute left and/or right eigenvectors
* (CWorkspace: need 2*N, prefer N + 2*N*NB)
* (RWorkspace: need 2*N)
*
IRWORK = IBAL + N
CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
$ N, NOUT, WORK( IWRK ), LWORK-IWRK+1,
$ RWORK( IRWORK ), N, IERR )
END IF
*
IF( WANTVL ) THEN
*
* Undo balancing of left eigenvectors
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL,
$ IERR )
*
* Normalize left eigenvectors and make largest component real
*
DO 20 I = 1, N
SCL = ONE / DZNRM2( N, VL( 1, I ), 1 )
CALL ZDSCAL( N, SCL, VL( 1, I ), 1 )
DO 10 K = 1, N
RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 +
$ AIMAG( VL( K, I ) )**2
10 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
CALL ZSCAL( N, TMP, VL( 1, I ), 1 )
VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO )
20 CONTINUE
END IF
*
IF( WANTVR ) THEN
*
* Undo balancing of right eigenvectors
* (CWorkspace: none)
* (RWorkspace: need N)
*
CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR,
$ IERR )
*
* Normalize right eigenvectors and make largest component real
*
DO 40 I = 1, N
SCL = ONE / DZNRM2( N, VR( 1, I ), 1 )
CALL ZDSCAL( N, SCL, VR( 1, I ), 1 )
DO 30 K = 1, N
RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 +
$ AIMAG( VR( K, I ) )**2
30 CONTINUE
K = IDAMAX( N, RWORK( IRWORK ), 1 )
TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
CALL ZSCAL( N, TMP, VR( 1, I ), 1 )
VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO )
40 CONTINUE
END IF
*
* Undo scaling if necessary
*
50 CONTINUE
IF( SCALEA ) THEN
CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
$ MAX( N-INFO, 1 ), IERR )
IF( INFO.GT.0 ) THEN
CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
END IF
END IF
*
WORK( 1 ) = MAXWRK
RETURN
*
* End of ZGEEV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zheevd.f 0000644 0000000 0000000 00000000132 14061636515 015311 x ustar 00 30 mtime=1623670093.133104146
30 atime=1623670093.133104146
30 ctime=1623670093.133104146
elk-7.2.42/src/LAPACK/zheevd.f 0000644 0025044 0025044 00000031337 14061636515 017355 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZHEEVD 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 ZHEEVD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
* LRWORK, IWORK, LIWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
*> complex Hermitian matrix A. If eigenvectors are desired, it uses a
*> divide and conquer algorithm.
*>
*> The divide and conquer algorithm makes very mild assumptions about
*> floating point arithmetic. It will work on machines with a guard
*> digit in add/subtract, or on those binary machines without guard
*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
*> Cray-2. It could conceivably fail on hexadecimal or decimal machines
*> without guard digits, but we know of none.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
*> orthonormal eigenvectors of the matrix A.
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
*> or the upper triangle (if UPLO='U') of A, including the
*> diagonal, is destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK.
*> If N <= 1, LWORK must be at least 1.
*> If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
*> If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal sizes of the WORK, RWORK and
*> IWORK arrays, returns these values as the first entries of
*> the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array,
*> dimension (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.
*
*> \date December 2016
*
*> \ingroup complex16HEeigen
*
*> \par Further Details:
* =====================
*>
*> Modified description of INFO. Sven, 16 Feb 05.
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*>
* =====================================================================
SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK driver routine (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 JOBZ, UPLO
INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2,
$ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
$ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL,
$ ZSTEDC, ZUNMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWMIN = 1
LRWMIN = 1
LIWMIN = 1
LOPT = LWMIN
LROPT = LRWMIN
LIOPT = LIWMIN
ELSE
IF( WANTZ ) THEN
LWMIN = 2*N + N*N
LRWMIN = 1 + 5*N + 2*N**2
LIWMIN = 3 + 5*N
ELSE
LWMIN = N + 1
LRWMIN = N
LIWMIN = 1
END IF
LOPT = MAX( LWMIN, N +
$ ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
LROPT = LRWMIN
LIOPT = LIWMIN
END IF
WORK( 1 ) = LOPT
RWORK( 1 ) = LROPT
IWORK( 1 ) = LIOPT
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
IF( WANTZ )
$ A( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
INDWRK = INDTAU + N
INDRWK = INDE + N
INDWK2 = INDWRK + N*N
LLWORK = LWORK - INDWRK + 1
LLWRK2 = LWORK - INDWK2 + 1
LLRWK = LRWORK - INDRWK + 1
CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
* tridiagonal matrix, then call ZUNMTR to multiply it to the
* Householder transformations represented as Householder vectors in
* A.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
$ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
$ IWORK, LIWORK, INFO )
CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
$ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
WORK( 1 ) = LOPT
RWORK( 1 ) = LROPT
IWORK( 1 ) = LIOPT
*
RETURN
*
* End of ZHEEVD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zheev.f 0000644 0000000 0000000 00000000132 14061636515 015145 x ustar 00 30 mtime=1623670093.135104144
30 atime=1623670093.135104144
30 ctime=1623670093.135104144
elk-7.2.42/src/LAPACK/zheev.f 0000644 0025044 0025044 00000021146 14061636515 017206 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZHEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for HE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEEV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
*> complex Hermitian matrix A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the
*> orthonormal eigenvectors of the matrix A.
*> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
*> or the upper triangle (if UPLO='U') of A, including the
*> diagonal, is destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,2*N-1).
*> For optimal efficiency, LWORK >= (NB+1)*N,
*> where NB is the blocksize for ZHETRD returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (max(1, 3*N-2))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the algorithm failed to converge; i
*> off-diagonal elements of an intermediate tridiagonal
*> form did not converge to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEeigen
*
* =====================================================================
SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
$ INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL LOWER, LQUERY, WANTZ
INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
$ LLWORK, LWKOPT, NB
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR,
$ ZUNGTR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
LOWER = LSAME( UPLO, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = MAX( 1, ( NB+1 )*N )
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY )
$ INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEV ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 1
IF( WANTZ )
$ A( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 )
$ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZUNGTR to generate the unitary matrix, then call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
$ LLWORK, IINFO )
INDWRK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA,
$ RWORK( INDWRK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* Set WORK(1) to optimal complex workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZHEEV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgesv.f 0000644 0000000 0000000 00000000132 14061636515 015162 x ustar 00 30 mtime=1623670093.137104142
30 atime=1623670093.136104143
30 ctime=1623670093.137104142
elk-7.2.42/src/LAPACK/zgesv.f 0000644 0025044 0025044 00000012032 14061636515 017215 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESV computes the solution to a complex system of linear equations
*> A * X = B,
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as
*> A = P * L * U,
*> where P is a permutation matrix, L is unit lower triangular, and U is
*> upper triangular. The factored form of A is then used to solve the
*> system of equations A * X = B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of linear equations, i.e., the order of the
*> matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N coefficient matrix A.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices that define the permutation matrix P;
*> row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the N-by-NRHS matrix of right hand side matrix B.
*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, so the solution could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16GEsolve
*
* =====================================================================
SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver 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, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. External Subroutines ..
EXTERNAL XERBLA, ZGETRF, ZGETRS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( NRHS.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESV ', -INFO )
RETURN
END IF
*
* Compute the LU factorization of A.
*
CALL ZGETRF( N, N, A, LDA, IPIV, INFO )
IF( INFO.EQ.0 ) THEN
*
* Solve the system A*X = B, overwriting B with X.
*
CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
$ INFO )
END IF
RETURN
*
* End of ZGESV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dgetrf.f 0000644 0000000 0000000 00000000132 14061636515 015277 x ustar 00 30 mtime=1623670093.138104141
30 atime=1623670093.138104141
30 ctime=1623670093.138104141
elk-7.2.42/src/LAPACK/dgetrf.f 0000644 0025044 0025044 00000014226 14061636515 017341 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGETRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGETRF computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the right-looking Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
SUBROUTINE DGETRF( M, N, A, LDA, IPIV, 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, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO, J, JB, NB
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
* Use unblocked code.
*
CALL DGETRF2( M, N, A, LDA, IPIV, INFO )
ELSE
*
* Use blocked code.
*
DO 20 J = 1, MIN( M, N ), NB
JB = MIN( MIN( M, N )-J+1, NB )
*
* Factor diagonal and subdiagonal blocks and test for exact
* singularity.
*
CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
* Adjust INFO and the pivot indices.
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + J - 1
DO 10 I = J, MIN( M, J+JB-1 )
IPIV( I ) = J - 1 + IPIV( I )
10 CONTINUE
*
* Apply interchanges to columns 1:J-1.
*
CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
IF( J+JB.LE.N ) THEN
*
* Apply interchanges to columns J+JB:N.
*
CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
$ IPIV, 1 )
*
* Compute block row of U.
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
$ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
$ LDA )
IF( J+JB.LE.M ) THEN
*
* Update trailing submatrix.
*
CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
$ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
$ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
$ LDA )
END IF
END IF
20 CONTINUE
END IF
RETURN
*
* End of DGETRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dgetri.f 0000644 0000000 0000000 00000000132 14061636515 015302 x ustar 00 30 mtime=1623670093.140104139
30 atime=1623670093.140104139
30 ctime=1623670093.140104139
elk-7.2.42/src/LAPACK/dgetri.f 0000644 0025044 0025044 00000016315 14061636515 017345 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGETRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETRI + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGETRI computes the inverse of a matrix using the LU factorization
*> computed by DGETRF.
*>
*> This method inverts U and then computes inv(A) by solving the system
*> inv(A)*L = inv(U) for inv(A).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the factors L and U from the factorization
*> A = P*L*U as computed by DGETRF.
*> On exit, if INFO = 0, the inverse of the original matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from DGETRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimal performance LWORK >= N*NB, where NB is
*> the optimal blocksize returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
*> singular and its inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, 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, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
* and the inverse is not computed.
*
CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL DGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of DGETRI
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgesvd.f 0000644 0000000 0000000 00000000132 14061636515 015326 x ustar 00 30 mtime=1623670093.143104137
30 atime=1623670093.141104139
30 ctime=1623670093.143104137
elk-7.2.42/src/LAPACK/zgesvd.f 0000644 0025044 0025044 00000426453 14061636515 017401 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZGESVD computes the singular value decomposition (SVD) for GE matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGESVD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
* WORK, LWORK, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBU, JOBVT
* INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION RWORK( * ), S( * )
* COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGESVD computes the singular value decomposition (SVD) of a complex
*> M-by-N matrix A, optionally computing the left and/or right singular
*> vectors. The SVD is written
*>
*> A = U * SIGMA * conjugate-transpose(V)
*>
*> where SIGMA is an M-by-N matrix which is zero except for its
*> min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
*> V is an N-by-N unitary matrix. The diagonal elements of SIGMA
*> are the singular values of A; they are real and non-negative, and
*> are returned in descending order. The first min(m,n) columns of
*> U and V are the left and right singular vectors of A.
*>
*> Note that the routine returns V**H, not V.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBU
*> \verbatim
*> JOBU is CHARACTER*1
*> Specifies options for computing all or part of the matrix U:
*> = 'A': all M columns of U are returned in array U:
*> = 'S': the first min(m,n) columns of U (the left singular
*> vectors) are returned in the array U;
*> = 'O': the first min(m,n) columns of U (the left singular
*> vectors) are overwritten on the array A;
*> = 'N': no columns of U (no left singular vectors) are
*> computed.
*> \endverbatim
*>
*> \param[in] JOBVT
*> \verbatim
*> JOBVT is CHARACTER*1
*> Specifies options for computing all or part of the matrix
*> V**H:
*> = 'A': all N rows of V**H are returned in the array VT;
*> = 'S': the first min(m,n) rows of V**H (the right singular
*> vectors) are returned in the array VT;
*> = 'O': the first min(m,n) rows of V**H (the right singular
*> vectors) are overwritten on the array A;
*> = 'N': no rows of V**H (no right singular vectors) are
*> computed.
*>
*> JOBVT and JOBU cannot both be 'O'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the input matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the input matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit,
*> if JOBU = 'O', A is overwritten with the first min(m,n)
*> columns of U (the left singular vectors,
*> stored columnwise);
*> if JOBVT = 'O', A is overwritten with the first min(m,n)
*> rows of V**H (the right singular vectors,
*> stored rowwise);
*> if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
*> are destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension (min(M,N))
*> The singular values of A, sorted so that S(i) >= S(i+1).
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*> U is COMPLEX*16 array, dimension (LDU,UCOL)
*> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
*> If JOBU = 'A', U contains the M-by-M unitary matrix U;
*> if JOBU = 'S', U contains the first min(m,n) columns of U
*> (the left singular vectors, stored columnwise);
*> if JOBU = 'N' or 'O', U is not referenced.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> The leading dimension of the array U. LDU >= 1; if
*> JOBU = 'S' or 'A', LDU >= M.
*> \endverbatim
*>
*> \param[out] VT
*> \verbatim
*> VT is COMPLEX*16 array, dimension (LDVT,N)
*> If JOBVT = 'A', VT contains the N-by-N unitary matrix
*> V**H;
*> if JOBVT = 'S', VT contains the first min(m,n) rows of
*> V**H (the right singular vectors, stored rowwise);
*> if JOBVT = 'N' or 'O', VT is not referenced.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*> LDVT is INTEGER
*> The leading dimension of the array VT. LDVT >= 1; if
*> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).
*> For good performance, LWORK should generally be larger.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (5*min(M,N))
*> On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
*> unconverged superdiagonal elements of an upper bidiagonal
*> matrix B whose diagonal is in S (not necessarily sorted).
*> B satisfies A = U * B * VT, so it has the same singular
*> values as A, and singular vectors related by U and VT.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if ZBDSQR did not converge, INFO specifies how many
*> superdiagonals of an intermediate bidiagonal form B
*> did not converge to zero. See the description of RWORK
*> above for details.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16GEsing
*
* =====================================================================
SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
$ VT, LDVT, WORK, LWORK, RWORK, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER JOBU, JOBVT
INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), S( * )
COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
$ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
$ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
$ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
$ NRVT, WRKBL
INTEGER LWORK_ZGEQRF, LWORK_ZUNGQR_N, LWORK_ZUNGQR_M,
$ LWORK_ZGEBRD, LWORK_ZUNGBR_P, LWORK_ZUNGBR_Q,
$ LWORK_ZGELQF, LWORK_ZUNGLQ_N, LWORK_ZUNGLQ_M
DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
* ..
* .. Local Arrays ..
DOUBLE PRECISION DUM( 1 )
COMPLEX*16 CDUM( 1 )
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM,
$ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ,
$ ZUNGQR, ZUNMBR
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANGE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
MINMN = MIN( M, N )
WNTUA = LSAME( JOBU, 'A' )
WNTUS = LSAME( JOBU, 'S' )
WNTUAS = WNTUA .OR. WNTUS
WNTUO = LSAME( JOBU, 'O' )
WNTUN = LSAME( JOBU, 'N' )
WNTVA = LSAME( JOBVT, 'A' )
WNTVS = LSAME( JOBVT, 'S' )
WNTVAS = WNTVA .OR. WNTVS
WNTVO = LSAME( JOBVT, 'O' )
WNTVN = LSAME( JOBVT, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
INFO = -1
ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
$ ( WNTVO .AND. WNTUO ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
INFO = -9
ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
$ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
INFO = -11
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* CWorkspace refers to complex workspace, and RWorkspace to
* real workspace. NB refers to the optimal block size for the
* immediately following subroutine, as returned by ILAENV.)
*
IF( INFO.EQ.0 ) THEN
MINWRK = 1
MAXWRK = 1
IF( M.GE.N .AND. MINMN.GT.0 ) THEN
*
* Space needed for ZBDSQR is BDSPAC = 5*N
*
MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
* Compute space needed for ZGEQRF
CALL ZGEQRF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEQRF = INT( CDUM(1) )
* Compute space needed for ZUNGQR
CALL ZUNGQR( M, N, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGQR_N = INT( CDUM(1) )
CALL ZUNGQR( M, M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGQR_M = INT( CDUM(1) )
* Compute space needed for ZGEBRD
CALL ZGEBRD( N, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD = INT( CDUM(1) )
* Compute space needed for ZUNGBR
CALL ZUNGBR( 'P', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P = INT( CDUM(1) )
CALL ZUNGBR( 'Q', N, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q = INT( CDUM(1) )
*
IF( M.GE.MNTHR ) THEN
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
*
MAXWRK = N + LWORK_ZGEQRF
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZGEBRD )
IF( WNTVO .OR. WNTVAS )
$ MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
MINWRK = 3*N
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
MINWRK = 2*N + M
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = 2*N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUS .AND. WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_N )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = 2*N*N + WRKBL
MINWRK = 2*N + M
ELSE IF( WNTUA .AND. WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
* 'A')
*
WRKBL = N + LWORK_ZGEQRF
WRKBL = MAX( WRKBL, N+LWORK_ZUNGQR_M )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_Q )
WRKBL = MAX( WRKBL, 2*N+LWORK_ZUNGBR_P )
MAXWRK = N*N + WRKBL
MINWRK = 2*N + M
END IF
ELSE
*
* Path 10 (M at least N, but not much larger)
*
CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD = INT( CDUM(1) )
MAXWRK = 2*N + LWORK_ZGEBRD
IF( WNTUS .OR. WNTUO ) THEN
CALL ZUNGBR( 'Q', M, N, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
END IF
IF( WNTUA ) THEN
CALL ZUNGBR( 'Q', M, M, N, A, LDA, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_Q )
END IF
IF( .NOT.WNTVN ) THEN
MAXWRK = MAX( MAXWRK, 2*N+LWORK_ZUNGBR_P )
END IF
MINWRK = 2*N + M
END IF
ELSE IF( MINMN.GT.0 ) THEN
*
* Space needed for ZBDSQR is BDSPAC = 5*M
*
MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
* Compute space needed for ZGELQF
CALL ZGELQF( M, N, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGELQF = INT( CDUM(1) )
* Compute space needed for ZUNGLQ
CALL ZUNGLQ( N, N, M, CDUM(1), N, CDUM(1), CDUM(1), -1,
$ IERR )
LWORK_ZUNGLQ_N = INT( CDUM(1) )
CALL ZUNGLQ( M, N, M, A, LDA, CDUM(1), CDUM(1), -1, IERR )
LWORK_ZUNGLQ_M = INT( CDUM(1) )
* Compute space needed for ZGEBRD
CALL ZGEBRD( M, M, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD = INT( CDUM(1) )
* Compute space needed for ZUNGBR P
CALL ZUNGBR( 'P', M, M, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P = INT( CDUM(1) )
* Compute space needed for ZUNGBR Q
CALL ZUNGBR( 'Q', M, M, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_Q = INT( CDUM(1) )
IF( N.GE.MNTHR ) THEN
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
*
MAXWRK = M + LWORK_ZGELQF
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZGEBRD )
IF( WNTUO .OR. WNTUAS )
$ MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
MINWRK = 3*M
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
MINWRK = 2*M + N
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A',
* JOBVT='O')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = 2*M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVS .AND. WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_M )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = 2*M*M + WRKBL
MINWRK = 2*M + N
ELSE IF( WNTVA .AND. WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
*
WRKBL = M + LWORK_ZGELQF
WRKBL = MAX( WRKBL, M+LWORK_ZUNGLQ_N )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZGEBRD )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_P )
WRKBL = MAX( WRKBL, 2*M+LWORK_ZUNGBR_Q )
MAXWRK = M*M + WRKBL
MINWRK = 2*M + N
END IF
ELSE
*
* Path 10t(N greater than M, but not much larger)
*
CALL ZGEBRD( M, N, A, LDA, S, DUM(1), CDUM(1),
$ CDUM(1), CDUM(1), -1, IERR )
LWORK_ZGEBRD = INT( CDUM(1) )
MAXWRK = 2*M + LWORK_ZGEBRD
IF( WNTVS .OR. WNTVO ) THEN
* Compute space needed for ZUNGBR P
CALL ZUNGBR( 'P', M, N, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
END IF
IF( WNTVA ) THEN
CALL ZUNGBR( 'P', N, N, M, A, N, CDUM(1),
$ CDUM(1), -1, IERR )
LWORK_ZUNGBR_P = INT( CDUM(1) )
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_P )
END IF
IF( .NOT.WNTUN ) THEN
MAXWRK = MAX( MAXWRK, 2*M+LWORK_ZUNGBR_Q )
END IF
MINWRK = 2*M + N
END IF
END IF
MAXWRK = MAX( MAXWRK, MINWRK )
WORK( 1 ) = MAXWRK
*
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGESVD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
* Get machine constants
*
EPS = DLAMCH( 'P' )
SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
BIGNUM = ONE / SMLNUM
*
* Scale A if max element outside range [SMLNUM,BIGNUM]
*
ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
ISCL = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
ISCL = 1
CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
ELSE IF( ANRM.GT.BIGNUM ) THEN
ISCL = 1
CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
END IF
*
IF( M.GE.N ) THEN
*
* A has at least as many rows as columns. If A has sufficiently
* more rows than columns, first reduce using the QR
* decomposition (if sufficient workspace available)
*
IF( M.GE.MNTHR ) THEN
*
IF( WNTUN ) THEN
*
* Path 1 (M much larger than N, JOBU='N')
* No left singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: need 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out below R
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
$ LDA )
END IF
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
NCVT = 0
IF( WNTVO .OR. WNTVAS ) THEN
*
* If right singular vectors desired, generate P'.
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
NCVT = N
END IF
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A if desired
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
$ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
*
* If right singular vectors desired in VT, copy them there
*
IF( WNTVAS )
$ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
*
ELSE IF( WNTUO .AND. WNTVN ) THEN
*
* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
* N left singular vectors to be overwritten on A and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
*
* WORK(IU) is LDA by N, WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR) and zero out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: need 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
$ WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (CWorkspace: need N*N+N, prefer N*N+M*N)
* (RWorkspace: 0)
*
DO 10 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
10 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing A
* (CWorkspace: need 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A
* (CWorkspace: need 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
$ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO .AND. WNTVAS ) THEN
*
* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
* N left singular vectors to be overwritten on A and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
LDWRKR = N
ELSE
*
* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
*
LDWRKU = ( LWORK-N*N ) / N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT, copying result to WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR) and computing right
* singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in WORK(IU) and copying to A
* (CWorkspace: need N*N+N, prefer N*N+M*N)
* (RWorkspace: 0)
*
DO 20 I = 1, M, LDWRKU
CHUNK = MIN( M-I+1, LDWRKU )
CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
$ LDA, WORK( IR ), LDWRKR, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
$ A( I, 1 ), LDA )
20 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
*
* Generate Q in A
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in A by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTUS ) THEN
*
IF( WNTVN ) THEN
*
* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
* N left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
$ 1, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IR), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IR ), LDWRKR, CZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
$ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
* N left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*N*N+3*N,
* prefer 2*N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*N*N+3*N-1,
* prefer 2*N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (CWorkspace: need 2*N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IU ), LDWRKU, CZERO, U, LDU )
*
* Copy right singular vectors of R to A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left vectors bidiagonalizing R
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing R in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
* or 'A')
* N left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+3*N ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need N*N+3*N-1,
* prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in A by left singular vectors of R in
* WORK(IU), storing result in U
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
$ WORK( IU ), LDWRKU, CZERO, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
ELSE IF( WNTUA ) THEN
*
IF( WNTVN ) THEN
*
* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
* M left singular vectors to be computed in U and
* no right singular vectors to be computed
*
IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IR) is LDA by N
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is N by N
*
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Copy R to WORK(IR), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IR+1 ), LDWRKR )
*
* Generate Q in U
* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IR)
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
$ 1, WORK( IR ), LDWRKR, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IR), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
$ WORK( IR ), LDWRKR, CZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
$ 1, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVO ) THEN
*
* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
* M left singular vectors to be computed in U and
* N right singular vectors to be overwritten on A
*
IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is N by N
*
LDWRKU = LDA
IR = IU + LDWRKU*N
LDWRKR = N
ELSE
*
* WORK(IU) is N by N and WORK(IR) is N by N
*
LDWRKU = N
IR = IU + LDWRKU*N
LDWRKR = N
END IF
ITAU = IR + LDWRKR*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*N*N+3*N,
* prefer 2*N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*N*N+3*N-1,
* prefer 2*N*N+2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in WORK(IR)
* (CWorkspace: need 2*N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, WORK( IU ),
$ LDWRKU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
$ WORK( IU ), LDWRKU, CZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
* Copy right singular vectors of R from WORK(IR) to A
*
CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Zero out below R in A
*
IF( N .GT. 1 ) THEN
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ A( 2, 1 ), LDA )
END IF
*
* Bidiagonalize R in A
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in A
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
END IF
*
ELSE IF( WNTVAS ) THEN
*
* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
* or 'A')
* M left singular vectors to be computed in U and
* N right singular vectors to be computed in VT
*
IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*N ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is N by N
*
LDWRKU = N
END IF
ITAU = IU + LDWRKU*N
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ WORK( IU+1 ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in WORK(IU), copying result to VT
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
$ LDVT )
*
* Generate left bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need N*N+3*N-1,
* prefer N*N+2*N+(N-1)*NB)
* (RWorkspace: need 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of R in WORK(IU) and computing
* right singular vectors of R in VT
* (CWorkspace: need N*N)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
$ LDVT, WORK( IU ), LDWRKU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply Q in U by left singular vectors of R in
* WORK(IU), storing result in A
* (CWorkspace: need N*N)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
$ WORK( IU ), LDWRKU, CZERO, A, LDA )
*
* Copy left singular vectors of A from A to U
*
CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + N
*
* Compute A=Q*R, copying result to U
* (CWorkspace: need 2*N, prefer N+N*NB)
* (RWorkspace: 0)
*
CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
*
* Generate Q in U
* (CWorkspace: need N+M, prefer N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy R from A to VT, zeroing out below it
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
IF( N.GT.1 )
$ CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
$ VT( 2, 1 ), LDVT )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize R in VT
* (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply Q in U by left bidiagonalizing vectors
* in VT
* (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
$ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + N
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* M .LT. MNTHR
*
* Path 10 (M at least N, but not much larger)
* Reduce to bidiagonal form without QR decomposition
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + N
IWORK = ITAUP + N
*
* Bidiagonalize A
* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
* (RWorkspace: need N)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
IF( WNTUS )
$ NCU = N
IF( WNTUA )
$ NCU = M
CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (CWorkspace: need 3*N, prefer 2*N+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + N
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
END IF
*
END IF
*
ELSE
*
* A has more columns than rows. If A has sufficiently more
* columns than rows, first reduce using the LQ decomposition (if
* sufficient workspace available)
*
IF( N.GE.MNTHR ) THEN
*
IF( WNTVN ) THEN
*
* Path 1t(N much larger than M, JOBVT='N')
* No right singular vectors to be computed
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Zero out above L
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
$ LDA )
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUO .OR. WNTUAS ) THEN
*
* If left singular vectors desired, generate Q
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + M
NRU = 0
IF( WNTUO .OR. WNTUAS )
$ NRU = M
*
* Perform bidiagonal QR iteration, computing left singular
* vectors of A in A if desired
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
$ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
*
* If left singular vectors desired in U, copy them there
*
IF( WNTUAS )
$ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
*
ELSE IF( WNTVO .AND. WNTUN ) THEN
*
* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
* M right singular vectors to be overwritten on A and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR) and zero out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L
* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (CWorkspace: need M*M+M, prefer M*M+M*N)
* (RWorkspace: 0)
*
DO 30 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
30 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
$ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTVO .AND. WNTUAS ) THEN
*
* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
* M right singular vectors to be overwritten on A and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is LDA by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = LDA
ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
*
* WORK(IU) is LDA by N and WORK(IR) is M by M
*
LDWRKU = LDA
CHUNK = N
LDWRKR = M
ELSE
*
* WORK(IU) is M by CHUNK and WORK(IR) is M by M
*
LDWRKU = M
CHUNK = ( LWORK-M*M ) / M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing about above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U, copying result to WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
*
* Generate right vectors bidiagonalizing L in WORK(IR)
* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U, and computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
IU = ITAUQ
*
* Multiply right singular vectors of L in WORK(IR) by Q
* in A, storing result in WORK(IU) and copying to A
* (CWorkspace: need M*M+M, prefer M*M+M*N))
* (RWorkspace: 0)
*
DO 40 I = 1, N, CHUNK
BLK = MIN( N-I+1, CHUNK )
CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
$ LDWRKR, A( 1, I ), LDA, CZERO,
$ WORK( IU ), LDWRKU )
CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
$ A( 1, I ), LDA )
40 CONTINUE
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
$ LDU )
*
* Generate Q in A
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in A
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), A, LDA, WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left vectors bidiagonalizing L in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
$ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTVS ) THEN
*
IF( WNTUN ) THEN
*
* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
* M right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right vectors bidiagonalizing L in
* WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
$ LDWRKR, A, LDA, CZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy result to VT
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
$ LDVT, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out below it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*M*M+3*M,
* prefer 2*M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*M*M+3*M-1,
* prefer 2*M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (CWorkspace: need 2*M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, A, LDA, CZERO, VT, LDVT )
*
* Copy left singular vectors of L to A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right vectors bidiagonalizing L by Q in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors of L in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 6t(N much larger than M, JOBU='S' or 'A',
* JOBVT='S')
* M right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+3*M ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by N
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is LDA by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
*
* Generate Q in A
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need M*M+3*M-1,
* prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in A, storing result in VT
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, A, LDA, CZERO, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ U( 1, 2 ), LDU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
ELSE IF( WNTVA ) THEN
*
IF( WNTUN ) THEN
*
* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
* N right singular vectors to be computed in VT and
* no left singular vectors to be computed
*
IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IR = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IR) is LDA by M
*
LDWRKR = LDA
ELSE
*
* WORK(IR) is M by M
*
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Copy L to WORK(IR), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
$ LDWRKR )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IR+LDWRKR ), LDWRKR )
*
* Generate Q in VT
* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IR)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate right bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need M*M+3*M-1,
* prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of L in WORK(IR)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
$ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IR) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
$ LDWRKR, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
$ LDVT, CDUM, 1, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUO ) THEN
*
* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be overwritten on A
*
IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is LDA by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = LDA
ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
*
* WORK(IU) is LDA by M and WORK(IR) is M by M
*
LDWRKU = LDA
IR = IU + LDWRKU*M
LDWRKR = M
ELSE
*
* WORK(IU) is M by M and WORK(IR) is M by M
*
LDWRKU = M
IR = IU + LDWRKU*M
LDWRKR = M
END IF
ITAU = IR + LDWRKR*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to
* WORK(IR)
* (CWorkspace: need 2*M*M+3*M,
* prefer 2*M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
$ WORK( IR ), LDWRKR )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need 2*M*M+3*M-1,
* prefer 2*M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in WORK(IR)
* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
$ WORK( ITAUQ ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in WORK(IR) and computing
* right singular vectors of L in WORK(IU)
* (CWorkspace: need 2*M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, WORK( IR ),
$ LDWRKR, CDUM, 1, RWORK( IRWORK ),
$ INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
* Copy left singular vectors of A from WORK(IR) to A
*
CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
$ LDA )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Zero out above L in A
*
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ A( 1, 2 ), LDA )
*
* Bidiagonalize L in A
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in A by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in A and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
ELSE IF( WNTUAS ) THEN
*
* Path 9t(N much larger than M, JOBU='S' or 'A',
* JOBVT='A')
* N right singular vectors to be computed in VT and
* M left singular vectors to be computed in U
*
IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
*
* Sufficient workspace for a fast algorithm
*
IU = 1
IF( LWORK.GE.WRKBL+LDA*M ) THEN
*
* WORK(IU) is LDA by M
*
LDWRKU = LDA
ELSE
*
* WORK(IU) is M by M
*
LDWRKU = M
END IF
ITAU = IU + LDWRKU*M
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to WORK(IU), zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
$ LDWRKU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ WORK( IU+LDWRKU ), LDWRKU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in WORK(IU), copying result to U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
$ RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
$ LDU )
*
* Generate right bidiagonalizing vectors in WORK(IU)
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
$ WORK( ITAUP ), WORK( IWORK ),
$ LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of L in U and computing right
* singular vectors of L in WORK(IU)
* (CWorkspace: need M*M)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
$ WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
* Multiply right singular vectors of L in WORK(IU) by
* Q in VT, storing result in A
* (CWorkspace: need M*M)
* (RWorkspace: 0)
*
CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
$ LDWRKU, VT, LDVT, CZERO, A, LDA )
*
* Copy right singular vectors of A from A to VT
*
CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
*
ELSE
*
* Insufficient workspace for a fast algorithm
*
ITAU = 1
IWORK = ITAU + M
*
* Compute A=L*Q, copying result to VT
* (CWorkspace: need 2*M, prefer M+M*NB)
* (RWorkspace: 0)
*
CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
*
* Generate Q in VT
* (CWorkspace: need M+N, prefer M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Copy L to U, zeroing out above it
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
$ U( 1, 2 ), LDU )
IE = 1
ITAUQ = ITAU
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize L in U
* (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
* (RWorkspace: need M)
*
CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
$ WORK( ITAUQ ), WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Multiply right bidiagonalizing vectors in U by Q
* in VT
* (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
* (RWorkspace: 0)
*
CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
$ WORK( ITAUP ), VT, LDVT,
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
*
* Generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
IRWORK = IE + M
*
* Perform bidiagonal QR iteration, computing left
* singular vectors of A in U and computing right
* singular vectors of A in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1,
$ RWORK( IRWORK ), INFO )
*
END IF
*
END IF
*
END IF
*
ELSE
*
* N .LT. MNTHR
*
* Path 10t(N greater than M, but not much larger)
* Reduce to bidiagonal form without LQ decomposition
*
IE = 1
ITAUQ = 1
ITAUP = ITAUQ + M
IWORK = ITAUP + M
*
* Bidiagonalize A
* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
* (RWorkspace: M)
*
CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
$ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
$ IERR )
IF( WNTUAS ) THEN
*
* If left singular vectors desired in U, copy result to U
* and generate left bidiagonalizing vectors in U
* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVAS ) THEN
*
* If right singular vectors desired in VT, copy result to
* VT and generate right bidiagonalizing vectors in VT
* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
* (RWorkspace: 0)
*
CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
IF( WNTVA )
$ NRVT = N
IF( WNTVS )
$ NRVT = M
CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTUO ) THEN
*
* If left singular vectors desired in A, generate left
* bidiagonalizing vectors in A
* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IF( WNTVO ) THEN
*
* If right singular vectors desired in A, generate right
* bidiagonalizing vectors in A
* (CWorkspace: need 3*M, prefer 2*M+M*NB)
* (RWorkspace: 0)
*
CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
$ WORK( IWORK ), LWORK-IWORK+1, IERR )
END IF
IRWORK = IE + M
IF( WNTUAS .OR. WNTUO )
$ NRU = M
IF( WNTUN )
$ NRU = 0
IF( WNTVAS .OR. WNTVO )
$ NCVT = N
IF( WNTVN )
$ NCVT = 0
IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in U and computing right singular
* vectors in A
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
$ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
$ INFO )
ELSE
*
* Perform bidiagonal QR iteration, if desired, computing
* left singular vectors in A and computing right singular
* vectors in VT
* (CWorkspace: 0)
* (RWorkspace: need BDSPAC)
*
CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
$ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
$ INFO )
END IF
*
END IF
*
END IF
*
* Undo scaling if necessary
*
IF( ISCL.EQ.1 ) THEN
IF( ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
$ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
IF( ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
$ IERR )
IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
$ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
$ RWORK( IE ), MINMN, IERR )
END IF
*
* Return optimal workspace in WORK(1)
*
WORK( 1 ) = MAXWRK
*
RETURN
*
* End of ZGESVD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgetrf.f 0000644 0000000 0000000 00000000132 14061636515 015325 x ustar 00 30 mtime=1623670093.145104135
30 atime=1623670093.144104136
30 ctime=1623670093.145104135
elk-7.2.42/src/LAPACK/zgetrf.f 0000644 0025044 0025044 00000014237 14061636515 017371 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGETRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRF computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the right-looking Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, 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, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IINFO, J, JB, NB
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZGETRF2, ZLASWP, ZTRSM
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
* Use unblocked code.
*
CALL ZGETRF2( M, N, A, LDA, IPIV, INFO )
ELSE
*
* Use blocked code.
*
DO 20 J = 1, MIN( M, N ), NB
JB = MIN( MIN( M, N )-J+1, NB )
*
* Factor diagonal and subdiagonal blocks and test for exact
* singularity.
*
CALL ZGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
* Adjust INFO and the pivot indices.
*
IF( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + J - 1
DO 10 I = J, MIN( M, J+JB-1 )
IPIV( I ) = J - 1 + IPIV( I )
10 CONTINUE
*
* Apply interchanges to columns 1:J-1.
*
CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
IF( J+JB.LE.N ) THEN
*
* Apply interchanges to columns J+JB:N.
*
CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
$ IPIV, 1 )
*
* Compute block row of U.
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
$ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
$ LDA )
IF( J+JB.LE.M ) THEN
*
* Update trailing submatrix.
*
CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1,
$ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
$ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
$ LDA )
END IF
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZGETRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgetri.f 0000644 0000000 0000000 00000000132 14061636515 015330 x ustar 00 30 mtime=1623670093.146104134
30 atime=1623670093.146104134
30 ctime=1623670093.146104134
elk-7.2.42/src/LAPACK/zgetri.f 0000644 0025044 0025044 00000016365 14061636515 017400 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGETRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRI + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRI computes the inverse of a matrix using the LU factorization
*> computed by ZGETRF.
*>
*> This method inverts U and then computes inv(A) by solving the system
*> inv(A)*L = inv(U) for inv(A).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the factors L and U from the factorization
*> A = P*L*U as computed by ZGETRF.
*> On exit, if INFO = 0, the inverse of the original matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from ZGETRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimal performance LWORK >= N*NB, where NB is
*> the optimal blocksize returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
*> singular and its inverse could not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, 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, LDA, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
$ NBMIN, NN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -3
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRI', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular,
* and the inverse is not computed.
*
CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
IF( INFO.GT.0 )
$ RETURN
*
NBMIN = 2
LDWORK = N
IF( NB.GT.1 .AND. NB.LT.N ) THEN
IWS = MAX( LDWORK*NB, 1 )
IF( LWORK.LT.IWS ) THEN
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) )
END IF
ELSE
IWS = N
END IF
*
* Solve the equation inv(A)*L = inv(U) for inv(A).
*
IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
DO 20 J = N, 1, -1
*
* Copy current column of L to WORK and replace with zeros.
*
DO 10 I = J + 1, N
WORK( I ) = A( I, J )
A( I, J ) = ZERO
10 CONTINUE
*
* Compute current column of inv(A).
*
IF( J.LT.N )
$ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
$ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
20 CONTINUE
ELSE
*
* Use blocked code.
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 50 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
*
* Copy current block column of L to WORK and replace with
* zeros.
*
DO 40 JJ = J, J + JB - 1
DO 30 I = JJ + 1, N
WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
A( I, JJ ) = ZERO
30 CONTINUE
40 CONTINUE
*
* Compute current block column of inv(A).
*
IF( J+JB.LE.N )
$ CALL ZGEMM( 'No transpose', 'No transpose', N, JB,
$ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
$ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
$ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
50 CONTINUE
END IF
*
* Apply column interchanges.
*
DO 60 J = N - 1, 1, -1
JP = IPIV( J )
IF( JP.NE.J )
$ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
60 CONTINUE
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGETRI
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ilaenv.f 0000644 0000000 0000000 00000000132 14061636515 015302 x ustar 00 30 mtime=1623670093.148104132
30 atime=1623670093.148104132
30 ctime=1623670093.148104132
elk-7.2.42/src/LAPACK/ilaenv.f 0000644 0025044 0025044 00000050517 14061636515 017347 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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 NaN arithmetic can be trusted not to trap
*> =11: infinity arithmetic can be trusted not to trap
*> 12 <= ISPEC <= 16:
*> 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.
*
*> \date November 2019
*
*> \ingroup OTHERauxiliary
*
*> \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 (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. 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)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
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
END IF
ELSE IF( C2.EQ.'LA' ) THEN
IF( C3.EQ.'UUM' ) THEN
IF( SNAME ) THEN
NB = 64
ELSE
NB = 64
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
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
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 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: 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 <= 16: xHSEQR or related subroutines.
*
ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
RETURN
*
* End of ILAENV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/xerbla.f 0000644 0000000 0000000 00000000127 14061636515 015305 x ustar 00 29 mtime=1623670093.15010413
29 atime=1623670093.15010413
29 ctime=1623670093.15010413
elk-7.2.42/src/LAPACK/xerbla.f 0000644 0025044 0025044 00000005031 14061636515 017335 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b XERBLA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download XERBLA + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* 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.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE XERBLA( SRNAME, 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..--
* December 2016
*
* .. 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
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zpptrf.f 0000644 0000000 0000000 00000000132 14061636515 015351 x ustar 00 30 mtime=1623670093.152104128
30 atime=1623670093.152104128
30 ctime=1623670093.152104128
elk-7.2.42/src/LAPACK/zpptrf.f 0000644 0025044 0025044 00000014476 14061636515 017422 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZPPTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPPTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPPTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A stored in packed format.
*>
*> The factorization has the form
*> A = U**H * U, if UPLO = 'U', or
*> A = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> See below for further details.
*>
*> On exit, if INFO = 0, the triangular factor U or L from the
*> Cholesky factorization A = U**H*U or A = L*L**H, in the same
*> storage format as A.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The packed storage scheme is illustrated by the following example
*> when N = 4, UPLO = 'U':
*>
*> Two-dimensional storage of the Hermitian matrix A:
*>
*> a11 a12 a13 a14
*> a22 a23 a24
*> a33 a34 (aij = conjg(aji))
*> a44
*>
*> Packed storage of the upper triangle of A:
*>
*> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )
*
* -- LAPACK computational routine (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 INFO, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JC, JJ
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPPTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**H * U.
*
JJ = 0
DO 10 J = 1, N
JC = JJ + 1
JJ = JJ + J
*
* Compute elements 1:J-1 of column J.
*
IF( J.GT.1 )
$ CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit',
$ J-1, AP, AP( JC ), 1 )
*
* Compute U(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( AP( JJ ) ) - ZDOTC( J-1, AP( JC ), 1, AP( JC ),
$ 1 )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AP( JJ ) = SQRT( AJJ )
10 CONTINUE
ELSE
*
* Compute the Cholesky factorization A = L * L**H.
*
JJ = 1
DO 20 J = 1, N
*
* Compute L(J,J) and test for non-positive-definiteness.
*
AJJ = DBLE( AP( JJ ) )
IF( AJJ.LE.ZERO ) THEN
AP( JJ ) = AJJ
GO TO 30
END IF
AJJ = SQRT( AJJ )
AP( JJ ) = AJJ
*
* Compute elements J+1:N of column J and update the trailing
* submatrix.
*
IF( J.LT.N ) THEN
CALL ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
CALL ZHPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
$ AP( JJ+N-J+1 ) )
JJ = JJ + N - J + 1
END IF
20 CONTINUE
END IF
GO TO 40
*
30 CONTINUE
INFO = J
*
40 CONTINUE
RETURN
*
* End of ZPPTRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhpgst.f 0000644 0000000 0000000 00000000132 14061636515 015343 x ustar 00 30 mtime=1623670093.154104127
30 atime=1623670093.153104127
30 ctime=1623670093.154104127
elk-7.2.42/src/LAPACK/zhpgst.f 0000644 0025044 0025044 00000020542 14061636515 017403 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPGST
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPGST + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, ITYPE, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), BP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPGST reduces a complex Hermitian-definite generalized
*> eigenproblem to standard form, using packed storage.
*>
*> If ITYPE = 1, the problem is A*x = lambda*B*x,
*> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
*>
*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
*> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
*>
*> B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
*> = 2 or 3: compute U*A*U**H or L**H*A*L.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored and B is factored as
*> U**H*U;
*> = 'L': Lower triangle of A is stored and B is factored as
*> L*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, if INFO = 0, the transformed matrix, stored in the
*> same format as A.
*> \endverbatim
*>
*> \param[in] BP
*> \verbatim
*> BP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The triangular factor from the Cholesky factorization of B,
*> stored in the same format as A, as returned by ZPPTRF.
*> \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 complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, 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 UPLO
INTEGER INFO, ITYPE, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), BP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, HALF
PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
DOUBLE PRECISION AJJ, AKK, BJJ, BKK
COMPLEX*16 CT
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHPMV, ZHPR2, ZTPMV,
$ ZTPSV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPGST', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U**H)*A*inv(U)
*
* J1 and JJ are the indices of A(1,j) and A(j,j)
*
JJ = 0
DO 10 J = 1, N
J1 = JJ + 1
JJ = JJ + J
*
* Compute the j-th column of the upper triangle of A
*
AP( JJ ) = DBLE( AP( JJ ) )
BJJ = BP( JJ )
CALL ZTPSV( UPLO, 'Conjugate transpose', 'Non-unit', J,
$ BP, AP( J1 ), 1 )
CALL ZHPMV( UPLO, J-1, -CONE, AP, BP( J1 ), 1, CONE,
$ AP( J1 ), 1 )
CALL ZDSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
AP( JJ ) = ( AP( JJ )-ZDOTC( J-1, AP( J1 ), 1, BP( J1 ),
$ 1 ) ) / BJJ
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L**H)
*
* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
*
KK = 1
DO 20 K = 1, N
K1K1 = KK + N - K + 1
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = AP( KK )
BKK = BP( KK )
AKK = AKK / BKK**2
AP( KK ) = AKK
IF( K.LT.N ) THEN
CALL ZDSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
CT = -HALF*AKK
CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL ZHPR2( UPLO, N-K, -CONE, AP( KK+1 ), 1,
$ BP( KK+1 ), 1, AP( K1K1 ) )
CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
CALL ZTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ BP( K1K1 ), AP( KK+1 ), 1 )
END IF
KK = K1K1
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U**H
*
* K1 and KK are the indices of A(1,k) and A(k,k)
*
KK = 0
DO 30 K = 1, N
K1 = KK + 1
KK = KK + K
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = AP( KK )
BKK = BP( KK )
CALL ZTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
$ AP( K1 ), 1 )
CT = HALF*AKK
CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL ZHPR2( UPLO, K-1, CONE, AP( K1 ), 1, BP( K1 ), 1,
$ AP )
CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
CALL ZDSCAL( K-1, BKK, AP( K1 ), 1 )
AP( KK ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L**H *A*L
*
* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
*
JJ = 1
DO 40 J = 1, N
J1J1 = JJ + N - J + 1
*
* Compute the j-th column of the lower triangle of A
*
AJJ = AP( JJ )
BJJ = BP( JJ )
AP( JJ ) = AJJ*BJJ + ZDOTC( N-J, AP( JJ+1 ), 1,
$ BP( JJ+1 ), 1 )
CALL ZDSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
CALL ZHPMV( UPLO, N-J, CONE, AP( J1J1 ), BP( JJ+1 ), 1,
$ CONE, AP( JJ+1 ), 1 )
CALL ZTPMV( UPLO, 'Conjugate transpose', 'Non-unit',
$ N-J+1, BP( JJ ), AP( JJ ), 1 )
JJ = J1J1
40 CONTINUE
END IF
END IF
RETURN
*
* End of ZHPGST
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhpevx.f 0000644 0000000 0000000 00000000132 14061636515 015350 x ustar 00 30 mtime=1623670093.156104125
30 atime=1623670093.155104125
30 ctime=1623670093.156104125
elk-7.2.42/src/LAPACK/zhpevx.f 0000644 0025044 0025044 00000037627 14061636515 017424 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPEVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
* ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK,
* IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, IU, LDZ, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPEVX computes selected eigenvalues and, optionally, eigenvectors
*> of a complex Hermitian matrix A in packed storage.
*> Eigenvalues/vectors can be selected by specifying either a range of
*> values or a range of indices for the desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found;
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found;
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>
*> On exit, AP is overwritten by values generated during the
*> reduction to tridiagonal form. If UPLO = 'U', the diagonal
*> and first superdiagonal of the tridiagonal matrix T overwrite
*> the corresponding elements of A, and if UPLO = 'L', the
*> diagonal and first subdiagonal of T overwrite the
*> corresponding elements of A.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing AP to tridiagonal form.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*>
*> See "Computing Small Singular Values of Bidiagonal Matrices
*> with Guaranteed High Relative Accuracy," by Demmel and
*> Kahan, LAPACK Working Note #3.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> If INFO = 0, the selected eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M))
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and
*> the index of the eigenvector is returned in IFAIL.
*> If JOBZ = 'N', then Z is not referenced.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (7*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: if INFO = i, then i eigenvectors failed to converge.
*> Their indices are stored in array IFAIL.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHEReigen
*
* =====================================================================
SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
$ ITMP1, J, JJ, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHP
EXTERNAL LSAME, DLAMCH, ZLANHP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
$ ZHPTRD, ZSTEIN, ZSTEQR, ZSWAP, ZUPGTR, ZUPMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -7
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -9
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
$ INFO = -14
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPEVX', -INFO )
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = AP( 1 )
ELSE
IF( VL.LT.DBLE( AP( 1 ) ) .AND. VU.GE.DBLE( AP( 1 ) ) ) THEN
M = 1
W( 1 ) = AP( 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
ELSE
VLL = ZERO
VUU = ZERO
END IF
ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDRWK = INDE + N
INDTAU = 1
INDWRK = INDTAU + N
CALL ZHPTRD( UPLO, N, AP, RWORK( INDD ), RWORK( INDE ),
$ WORK( INDTAU ), IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal
* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails
* for some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF (INDEIG) THEN
IF (IL.EQ.1 .AND. IU.EQ.N) THEN
TEST = .TRUE.
END IF
END IF
IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
INDEE = INDRWK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL DSTERF( N, W, RWORK( INDEE ), INFO )
ELSE
CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 10 I = 1, N
IFAIL( I ) = 0
10 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 20
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWK = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
$ IWORK( INDIWK ), INFO )
*
IF( WANTZ ) THEN
CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
*
* Apply unitary matrix used in reduction to tridiagonal
* form to eigenvectors returned by ZSTEIN.
*
INDWRK = INDTAU + N
CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
20 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 40 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 30 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
30 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
40 CONTINUE
END IF
*
RETURN
*
* End of ZHPEVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dgetrs.f 0000644 0000000 0000000 00000000132 14061636515 015314 x ustar 00 30 mtime=1623670093.157104124
30 atime=1623670093.157104124
30 ctime=1623670093.157104124
elk-7.2.42/src/LAPACK/dgetrs.f 0000644 0025044 0025044 00000013564 14061636515 017362 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGETRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGETRS solves a system of linear equations
*> A * X = B or A**T * X = B
*> with a general N-by-N matrix A using the LU factorization computed
*> by DGETRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the form of the system of equations:
*> = 'N': A * X = B (No transpose)
*> = 'T': A**T* X = B (Transpose)
*> = 'C': A**T* X = B (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by DGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from DGETRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, 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 TRANS
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLASWP, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( NOTRAN ) THEN
*
* Solve A * X = B.
*
* Apply row interchanges to the right hand sides.
*
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
* Solve L*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve U*X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* Solve A**T * X = B.
*
* Solve U**T *X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve L**T *X = B, overwriting B with X.
*
CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
$ A, LDA, B, LDB )
*
* Apply row interchanges to the solution vectors.
*
CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
END IF
*
RETURN
*
* End of DGETRS
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dgetrf2.f 0000644 0000000 0000000 00000000132 14061636515 015361 x ustar 00 30 mtime=1623670093.159104122
30 atime=1623670093.159104122
30 ctime=1623670093.159104122
elk-7.2.42/src/LAPACK/dgetrf2.f 0000644 0025044 0025044 00000015602 14061636515 017422 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DGETRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGETRF2 computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = min(m,n)/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> [ A11 ]
*> The subroutine calls itself to factor [ --- ],
*> [ A12 ]
*> [ A12 ]
*> do the swaps on [ --- ], solve A12, update A22,
*> [ A22 ]
*>
*> then calls itself to factor A22 and do the swaps on A21.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the M-by-N matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleGEcomputational
*
* =====================================================================
RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, 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 INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION SFMIN, TEMP
INTEGER I, IINFO, N1, N2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IDAMAX
EXTERNAL DLAMCH, IDAMAX
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGETRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
IF ( M.EQ.1 ) THEN
*
* Use unblocked code for one row case
* Just need to handle IPIV and INFO
*
IPIV( 1 ) = 1
IF ( A(1,1).EQ.ZERO )
$ INFO = 1
*
ELSE IF( N.EQ.1 ) THEN
*
* Use unblocked code for one column case
*
*
* Compute machine safe minimum
*
SFMIN = DLAMCH('S')
*
* Find pivot and test for singularity
*
I = IDAMAX( M, A( 1, 1 ), 1 )
IPIV( 1 ) = I
IF( A( I, 1 ).NE.ZERO ) THEN
*
* Apply the interchange
*
IF( I.NE.1 ) THEN
TEMP = A( 1, 1 )
A( 1, 1 ) = A( I, 1 )
A( I, 1 ) = TEMP
END IF
*
* Compute elements 2:M of the column
*
IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN
CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )
ELSE
DO 10 I = 1, M-1
A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )
10 CONTINUE
END IF
*
ELSE
INFO = 1
END IF
*
ELSE
*
* Use recursive code
*
N1 = MIN( M, N ) / 2
N2 = N-N1
*
* [ A11 ]
* Factor [ --- ]
* [ A21 ]
*
CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO )
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* [ A12 ]
* Apply interchanges to [ --- ]
* [ A22 ]
*
CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )
*
* Solve A12
*
CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA,
$ A( 1, N1+1 ), LDA )
*
* Update A22
*
CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )
*
* Factor A22
*
CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ),
$ IINFO )
*
* Adjust INFO and the pivot indices
*
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + N1
DO 20 I = N1+1, MIN( M, N )
IPIV( I ) = IPIV( I ) + N1
20 CONTINUE
*
* Apply interchanges to A21
*
CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )
*
END IF
RETURN
*
* End of DGETRF2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaswp.f 0000644 0000000 0000000 00000000132 14061636515 015316 x ustar 00 30 mtime=1623670093.160104121
30 atime=1623670093.160104121
30 ctime=1623670093.160104121
elk-7.2.42/src/LAPACK/dlaswp.f 0000644 0025044 0025044 00000012010 14061636515 017345 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASWP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASWP performs a series of row interchanges on the matrix A.
*> One row interchange is initiated for each of rows K1 through K2 of A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the matrix of column dimension N to which the row
*> interchanges will be applied.
*> On exit, the permuted matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] K1
*> \verbatim
*> K1 is INTEGER
*> The first element of IPIV for which a row interchange will
*> be done.
*> \endverbatim
*>
*> \param[in] K2
*> \verbatim
*> K2 is INTEGER
*> (K2-K1+1) is the number of elements of IPIV for which a row
*> interchange will be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
*> The vector of pivot indices. Only the elements in positions
*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
*> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
*> interchanged.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of IPIV. If INCX
*> is negative, the pivots are applied in reverse order.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Modified by
*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- 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 ..
INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
DOUBLE PRECISION TEMP
* ..
* .. Executable Statements ..
*
* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
* K1 through K2.
*
IF( INCX.GT.0 ) THEN
IX0 = K1
I1 = K1
I2 = K2
INC = 1
ELSE IF( INCX.LT.0 ) THEN
IX0 = K1 + ( K1-K2 )*INCX
I1 = K2
I2 = K1
INC = -1
ELSE
RETURN
END IF
*
N32 = ( N / 32 )*32
IF( N32.NE.0 ) THEN
DO 30 J = 1, N32, 32
IX = IX0
DO 20 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 10 K = J, J + 31
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
10 CONTINUE
END IF
IX = IX + INCX
20 CONTINUE
30 CONTINUE
END IF
IF( N32.NE.N ) THEN
N32 = N32 + 1
IX = IX0
DO 50 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 40 K = N32, N
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
40 CONTINUE
END IF
IX = IX + INCX
50 CONTINUE
END IF
*
RETURN
*
* End of DLASWP
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dtrtri.f 0000644 0000000 0000000 00000000132 14061636515 015334 x ustar 00 30 mtime=1623670093.162104119
30 atime=1623670093.162104119
30 ctime=1623670093.162104119
elk-7.2.42/src/LAPACK/dtrtri.f 0000644 0025044 0025044 00000015367 14061636515 017405 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTRTRI + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRTRI computes the inverse of a real upper or lower triangular
*> matrix A.
*>
*> This is the Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': A is upper triangular;
*> = 'L': A is lower triangular.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> = 'N': A is non-unit triangular;
*> = 'U': A is unit triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the triangular matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of the array A contains
*> the upper triangular matrix, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of the array A contains
*> the lower triangular matrix, and the strictly upper
*> triangular part of A is not referenced. If DIAG = 'U', the
*> diagonal elements of A are also not referenced and are
*> assumed to be 1.
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular
*> matrix is singular and its inverse can not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of DTRTRI
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlansy.f 0000644 0000000 0000000 00000000132 14061636515 015316 x ustar 00 30 mtime=1623670093.164104117
30 atime=1623670093.163104118
30 ctime=1623670093.164104117
elk-7.2.42/src/LAPACK/dlansy.f 0000644 0025044 0025044 00000017534 14061636515 017365 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLANSY 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 matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLANSY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLANSY 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 matrix A.
*> \endverbatim
*>
*> \return DLANSY
*> \verbatim
*>
*> DLANSY = ( 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 DLANSY as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is to be referenced.
*> = 'U': Upper triangular part of A is referenced
*> = 'L': Lower triangular part of A is referenced
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, DLANSY is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The symmetric matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of A contains the upper triangular part
*> of the matrix A, and the strictly lower triangular part of A
*> is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of A contains the lower triangular part of
*> the matrix A, and the strictly upper triangular part of A is
*> not referenced.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(N,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
*
* -- 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
*
IMPLICIT NONE
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SUM, VALUE
* ..
* .. Local Arrays ..
DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ, DCOMBSSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1, N
DO 30 I = J, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is symmetric).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( A( J, J ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( A( J, J ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
* SSQ(1) is scale
* SSQ(2) is sum-of-squares
* For better accuracy, sum each column separately.
*
SSQ( 1 ) = ZERO
SSQ( 2 ) = ONE
*
* Sum off-diagonals
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL DLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) )
CALL DCOMBSSQ( SSQ, COLSSQ )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL DLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) )
CALL DCOMBSSQ( SSQ, COLSSQ )
120 CONTINUE
END IF
SSQ( 2 ) = 2*SSQ( 2 )
*
* Sum diagonal
*
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL DLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
END IF
*
DLANSY = VALUE
RETURN
*
* End of DLANSY
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlascl.f 0000644 0000000 0000000 00000000132 14061636515 015266 x ustar 00 30 mtime=1623670093.165104116
30 atime=1623670093.165104116
30 ctime=1623670093.165104116
elk-7.2.42/src/LAPACK/dlascl.f 0000644 0025044 0025044 00000023427 14061636515 017333 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASCL 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 DLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TYPE
* INTEGER INFO, KL, KU, LDA, M, N
* DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASCL 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 DGBTRF for storage details.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The lower bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The upper bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] CFROM
*> \verbatim
*> CFROM is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*> CTO is DOUBLE PRECISION
*>
*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
*> without over/underflow if the final result CTO*A(I,J)/CFROM
*> can be represented without over/underflow. CFROM must be
*> nonzero.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DLASCL( 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
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( DISNAN(CTO) ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DLASCL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsytrd.f 0000644 0000000 0000000 00000000132 14061636515 015335 x ustar 00 30 mtime=1623670093.167104114
30 atime=1623670093.167104114
30 ctime=1623670093.167104114
elk-7.2.42/src/LAPACK/dsytrd.f 0000644 0025044 0025044 00000026346 14061636515 017405 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYTRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTRD reduces a real symmetric matrix A to real symmetric
*> tridiagonal form T by an orthogonal similarity transformation:
*> Q**T * 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 DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if 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 orthogonal
*> 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 orthogonal matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 1.
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYcomputational
*
*> \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**T
*>
*> where tau is a real scalar, and v is a real 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**T
*>
*> where tau is a real scalar, and v is a real 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 DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, 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 UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTRD', -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, 'DSYTRD', 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, 'DSYTRD', 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 DLATRD( 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**T - W*V**T
*
CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
$ LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL DSYTD2( 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 DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
* an update of the form: A := A - V*W**T - W*V**T
*
CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of DSYTRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsterf.f 0000644 0000000 0000000 00000000132 14061636515 015313 x ustar 00 30 mtime=1623670093.169104112
30 atime=1623670093.168104113
30 ctime=1623670093.169104112
elk-7.2.42/src/LAPACK/dsterf.f 0000644 0025044 0025044 00000024631 14061636515 017356 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSTERF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTERF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSTERF( N, D, E, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSTERF 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N-1)
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
*> matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[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 DSTERF( 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 ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
$ NMAXIT
DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN, RMAX
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLASCL, DLASRT, 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( 'DSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
RMAX = DLAMCH( 'O' )
*
* 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 = DLANST( '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 DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
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 DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL DLAE2( 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 = DLAPY2( 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 DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL DLAE2( 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 = DLAPY2( 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 DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL DLASCL( '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 DLASRT( 'I', N, D, INFO )
*
180 CONTINUE
RETURN
*
* End of DSTERF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorgtr.f 0000644 0000000 0000000 00000000132 14061636515 015325 x ustar 00 30 mtime=1623670093.170104112
30 atime=1623670093.170104112
30 ctime=1623670093.170104112
elk-7.2.42/src/LAPACK/dorgtr.f 0000644 0025044 0025044 00000015620 14061636515 017366 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORGTR generates a real orthogonal matrix Q which is defined as the
*> product of n-1 elementary reflectors of order N, as returned by
*> DSYTRD:
*>
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A contains elementary reflectors
*> from DSYTRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from DSYTRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by DSYTRD.
*> On exit, the N-by-N orthogonal matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DSYTRD.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N-1).
*> For optimum performance LWORK >= (N-1)*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, 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 UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, J, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORGQL, DORGQR, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
ELSE
NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
END IF
LWKOPT = MAX( 1, N-1 )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to DSYTRD with UPLO = 'U'
*
* Shift the vectors which define the elementary reflectors one
* column to the left, and set the last row and column of Q to
* those of the unit matrix
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q was determined by a call to DSYTRD with UPLO = 'L'.
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q to
* those of the unit matrix
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORGTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsteqr.f 0000644 0000000 0000000 00000000127 14061636515 015332 x ustar 00 29 mtime=1623670093.17210411
29 atime=1623670093.17210411
29 ctime=1623670093.17210411
elk-7.2.42/src/LAPACK/dsteqr.f 0000644 0025044 0025044 00000036276 14061636515 017401 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSTEQR 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 DSYTRD or DSPTRD or DSBTRD 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 DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
*> matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (max(1,2*N-2))
*> If COMPZ = 'N', then WORK is not referenced.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: the algorithm has failed to find all the eigenvalues in
*> a total of 30*N iterations; if INFO = i, then i
*> elements of E have not converged to zero; on exit, D
*> and E contain the elements of a symmetric tridiagonal
*> matrix which is 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 DSTEQR( 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 ..
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
$ DLASRT, DSWAP, 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( 'DSTEQR', -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 = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL DLASET( '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 = DLANST( '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 DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.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 DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
*
190 CONTINUE
RETURN
*
* End of DSTEQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dpotrf.f 0000644 0000000 0000000 00000000132 14061636515 015322 x ustar 00 30 mtime=1623670093.174104108
30 atime=1623670093.174104108
30 ctime=1623670093.174104108
elk-7.2.42/src/LAPACK/dpotrf.f 0000644 0025044 0025044 00000016046 14061636515 017366 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DPOTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DPOTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DPOTRF computes the Cholesky factorization of a real symmetric
*> positive definite matrix A.
*>
*> The factorization has the form
*> A = U**T * U, if UPLO = 'U', or
*> A = L * L**T, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the block version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**T*U or A = L*L**T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doublePOcomputational
*
* =====================================================================
SUBROUTINE DPOTRF( UPLO, N, A, LDA, 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 UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
CALL DPOTRF2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code.
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**T*U.
*
DO 10 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
$ A( 1, J ), LDA, ONE, A( J, J ), LDA )
CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block row.
*
CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
$ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
$ LDA, ONE, A( J, J+JB ), LDA )
CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
$ JB, N-J-JB+1, ONE, A( J, J ), LDA,
$ A( J, J+JB ), LDA )
END IF
10 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization A = L*L**T.
*
DO 20 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
$ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
CALL DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block column.
*
CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
$ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
$ LDA, ONE, A( J+JB, J ), LDA )
CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
$ N-J-JB+1, JB, ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
20 CONTINUE
END IF
END IF
GO TO 40
*
30 CONTINUE
INFO = INFO + J - 1
*
40 CONTINUE
RETURN
*
* End of DPOTRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsygst.f 0000644 0000000 0000000 00000000132 14061636515 015341 x ustar 00 30 mtime=1623670093.176104106
30 atime=1623670093.176104106
30 ctime=1623670093.176104106
elk-7.2.42/src/LAPACK/dsygst.f 0000644 0025044 0025044 00000025360 14061636515 017404 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYGST
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYGST + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYGST reduces a real symmetric-definite generalized eigenproblem
*> to standard form.
*>
*> If ITYPE = 1, the problem is A*x = lambda*B*x,
*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*>
*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
*>
*> B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
*> = 2 or 3: compute U*A*U**T or L**T*A*L.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored and B is factored as
*> U**T*U;
*> = 'L': Lower triangle of A is stored and B is factored as
*> L*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the transformed matrix, stored in the
*> same format as A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
*> The triangular factor from the Cholesky factorization of B,
*> as returned by DPOTRF.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYcomputational
*
* =====================================================================
SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, 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 UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, HALF
PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KB, NB
* ..
* .. External Subroutines ..
EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
ELSE
*
* Use blocked code
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U**T)*A*inv(U)
*
DO 10 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(k:n,k:n)
*
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
$ KB, N-K-KB+1, ONE, B( K, K ), LDB,
$ A( K, K+KB ), LDA )
CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
$ A( K, K+KB ), LDA, B( K, K+KB ), LDB,
$ ONE, A( K+KB, K+KB ), LDA )
CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
$ A( K, K+KB ), LDA )
CALL DTRSM( 'Right', UPLO, 'No transpose',
$ 'Non-unit', KB, N-K-KB+1, ONE,
$ B( K+KB, K+KB ), LDB, A( K, K+KB ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L**T)
*
DO 20 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(k:n,k:n)
*
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ N-K-KB+1, KB, ONE, B( K, K ), LDB,
$ A( K+KB, K ), LDA )
CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
$ -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
$ LDB, ONE, A( K+KB, K+KB ), LDA )
CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
$ A( K+KB, K ), LDA )
CALL DTRSM( 'Left', UPLO, 'No transpose',
$ 'Non-unit', N-K-KB+1, KB, ONE,
$ B( K+KB, K+KB ), LDB, A( K+KB, K ),
$ LDA )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U**T
*
DO 30 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
$ K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
$ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
$ LDA )
CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
$ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
$ LDA )
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
30 CONTINUE
ELSE
*
* Compute L**T*A*L
*
DO 40 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
$ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
$ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
$ LDA )
CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
$ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of DSYGST
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsyevx.f 0000644 0000000 0000000 00000000132 14061636515 015346 x ustar 00 30 mtime=1623670093.178104104
30 atime=1623670093.178104104
30 ctime=1623670093.178104104
elk-7.2.42/src/LAPACK/dsyevx.f 0000644 0025044 0025044 00000042616 14061636515 017414 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYEVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
* ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
* IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYEVX computes selected eigenvalues and, optionally, eigenvectors
*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be
*> selected by specifying either a range of values or a range of indices
*> for the desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found.
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found.
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \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 DOUBLE PRECISION array, dimension (LDA, N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> 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[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing A to tridiagonal form.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*>
*> See "Computing Small Singular Values of Bidiagonal Matrices
*> with Guaranteed High Relative Accuracy," by Demmel and
*> Kahan, LAPACK Working Note #3.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> On normal exit, the first M elements contain the selected
*> eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M))
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and the
*> index of the eigenvector is returned in IFAIL.
*> If JOBZ = 'N', then Z is not referenced.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= 1, when N <= 1;
*> otherwise 8*N.
*> For optimal efficiency, LWORK >= (NB+3)*N,
*> where NB is the max of the blocksize for DSYTRD and DORMTR
*> returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: if INFO = i, then i eigenvectors failed to converge.
*> Their indices are stored in array IFAIL.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleSYeigen
*
* =====================================================================
SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
$ IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
$ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
$ LWKOPT, NB, NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANSY
EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ,
$ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWKMIN = 1
WORK( 1 ) = LWKMIN
ELSE
LWKMIN = 8*N
NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
WORK( 1 ) = LWKOPT
END IF
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE
IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
END IF
ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
*
INDTAU = 1
INDE = INDTAU + N
INDD = INDE + N
INDWRK = INDD + N
LLWORK = LWORK - INDWRK + 1
CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
$ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal to
* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for
* some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
INDEE = INDWRK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTERF( N, W, WORK( INDEE ), INFO )
ELSE
CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
$ WORK( INDWRK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
IFAIL( I ) = 0
30 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 40
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWO = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
$ IWORK( INDIWO ), INFO )
*
IF( WANTZ ) THEN
CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
*
* Apply orthogonal matrix used in reduction to tridiagonal
* form to eigenvectors returned by DSTEIN.
*
INDWKN = INDE
LLWRKN = LWORK - INDWKN + 1
CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
40 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 60 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
50 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
60 CONTINUE
END IF
*
* Set WORK(1) to optimal workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of DSYEVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ieeeck.f 0000644 0000000 0000000 00000000132 14061636515 015251 x ustar 00 30 mtime=1623670093.180104102
30 atime=1623670093.180104102
30 ctime=1623670093.180104102
elk-7.2.42/src/LAPACK/ieeeck.f 0000644 0025044 0025044 00000010724 14061636515 017312 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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 inifinity 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.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* -- 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 ..
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
elk-7.2.42/src/LAPACK/PaxHeaders.21776/iparmq.f 0000644 0000000 0000000 00000000126 14061636515 015320 x ustar 00 28 mtime=1623670093.1821041
30 atime=1623670093.181104101
28 ctime=1623670093.1821041
elk-7.2.42/src/LAPACK/iparmq.f 0000644 0025044 0025044 00000033426 14061636515 017362 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \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.)
*> \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.
*
*> \date June 2017
*
*> \ingroup OTHERauxiliary
*
*> \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.
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
*
* -- 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 ..
INTEGER IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
*
* ================================================================
* .. Parameters ..
INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
$ ISHFTS = 15, IACC22 = 16 )
INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14,
$ NIBBLE = 14, KNWSWP = 500 )
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
* ===== invalid value of ispec =====
IPARMQ = -1
*
END IF
*
* ==== End of IPARMQ ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ztrevc3.f 0000644 0000000 0000000 00000000130 14061636515 015422 x ustar 00 30 mtime=1623670093.184104099
28 atime=1623670093.1831041
30 ctime=1623670093.184104099
elk-7.2.42/src/LAPACK/ztrevc3.f 0000644 0025044 0025044 00000051237 14061636515 017471 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTREVC3
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREVC3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
* $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
*
* .. Scalar Arguments ..
* CHARACTER HOWMNY, SIDE
* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N
* ..
* .. Array Arguments ..
* LOGICAL SELECT( * )
* DOUBLE PRECISION RWORK( * )
* COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTREVC3 computes some or all of the right and/or left eigenvectors of
*> a complex upper triangular matrix T.
*> Matrices of this type are produced by the Schur factorization of
*> a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
*>
*> The right eigenvector x and the left eigenvector y of T corresponding
*> to an eigenvalue w are defined by:
*>
*> T*x = w*x, (y**H)*T = w*(y**H)
*>
*> where y**H denotes the conjugate transpose of the vector y.
*> The eigenvalues are not input to this routine, but are read directly
*> from the diagonal of T.
*>
*> This routine returns the matrices X and/or Y of right and left
*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
*> input matrix. If Q is the unitary factor that reduces a matrix A to
*> Schur form T, then Q*X and Q*Y are the matrices of right and left
*> eigenvectors of A.
*>
*> This uses a Level 3 BLAS version of the back transformation.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'R': compute right eigenvectors only;
*> = 'L': compute left eigenvectors only;
*> = 'B': compute both right and left eigenvectors.
*> \endverbatim
*>
*> \param[in] HOWMNY
*> \verbatim
*> HOWMNY is CHARACTER*1
*> = 'A': compute all right and/or left eigenvectors;
*> = 'B': compute all right and/or left eigenvectors,
*> backtransformed using the matrices supplied in
*> VR and/or VL;
*> = 'S': compute selected right and/or left eigenvectors,
*> as indicated by the logical array SELECT.
*> \endverbatim
*>
*> \param[in] SELECT
*> \verbatim
*> SELECT is LOGICAL array, dimension (N)
*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be
*> computed.
*> The eigenvector corresponding to the j-th eigenvalue is
*> computed if SELECT(j) = .TRUE..
*> Not referenced if HOWMNY = 'A' or 'B'.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> The upper triangular matrix T. T is modified, but restored
*> on exit.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*> VL is COMPLEX*16 array, dimension (LDVL,MM)
*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
*> contain an N-by-N matrix Q (usually the unitary matrix Q of
*> Schur vectors returned by ZHSEQR).
*> On exit, if SIDE = 'L' or 'B', VL contains:
*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
*> if HOWMNY = 'B', the matrix Q*Y;
*> if HOWMNY = 'S', the left eigenvectors of T specified by
*> SELECT, stored consecutively in the columns
*> of VL, in the same order as their
*> eigenvalues.
*> Not referenced if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDVL
*> \verbatim
*> LDVL is INTEGER
*> The leading dimension of the array VL.
*> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N.
*> \endverbatim
*>
*> \param[in,out] VR
*> \verbatim
*> VR is COMPLEX*16 array, dimension (LDVR,MM)
*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
*> contain an N-by-N matrix Q (usually the unitary matrix Q of
*> Schur vectors returned by ZHSEQR).
*> On exit, if SIDE = 'R' or 'B', VR contains:
*> if HOWMNY = 'A', the matrix X of right eigenvectors of T;
*> if HOWMNY = 'B', the matrix Q*X;
*> if HOWMNY = 'S', the right eigenvectors of T specified by
*> SELECT, stored consecutively in the columns
*> of VR, in the same order as their
*> eigenvalues.
*> Not referenced if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDVR
*> \verbatim
*> LDVR is INTEGER
*> The leading dimension of the array VR.
*> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N.
*> \endverbatim
*>
*> \param[in] MM
*> \verbatim
*> MM is INTEGER
*> The number of columns in the arrays VL and/or VR. MM >= M.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The number of columns in the arrays VL and/or VR actually
*> used to store the eigenvectors.
*> If HOWMNY = 'A' or 'B', M is set to N.
*> Each selected eigenvector occupies one column.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of array WORK. LWORK >= max(1,2*N).
*> For optimum performance, LWORK >= N + 2*N*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (LRWORK)
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of array RWORK. LRWORK >= max(1,N).
*>
*> If LRWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the RWORK array, returns
*> this value as the first entry of the RWORK array, and no error
*> message related to LRWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
* @precisions fortran z -> c
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The algorithm used in this program is basically backward (forward)
*> substitution, with scaling to make the the code robust against
*> possible overflow.
*>
*> Each eigenvector is normalized so that the element of largest
*> magnitude has magnitude 1; here the magnitude of a complex number
*> (x,y) is taken to be |x| + |y|.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO)
IMPLICIT NONE
*
* -- LAPACK computational routine (version 3.8.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
CHARACTER HOWMNY, SIDE
INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N
* ..
* .. Array Arguments ..
LOGICAL SELECT( * )
DOUBLE PRECISION RWORK( * )
COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
INTEGER NBMIN, NBMAX
PARAMETER ( NBMIN = 8, NBMAX = 128 )
* ..
* .. Local Scalars ..
LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV
INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB
DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
COMPLEX*16 CDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV, IZAMAX
DOUBLE PRECISION DLAMCH, DZASUM
EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DZASUM
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS,
$ ZGEMM, DLABAD, ZLASET, ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, CONJG, AIMAG, MAX
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( AIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters
*
BOTHV = LSAME( SIDE, 'B' )
RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
*
ALLV = LSAME( HOWMNY, 'A' )
OVER = LSAME( HOWMNY, 'B' )
SOMEV = LSAME( HOWMNY, 'S' )
*
* Set M to the number of columns required to store the selected
* eigenvectors.
*
IF( SOMEV ) THEN
M = 0
DO 10 J = 1, N
IF( SELECT( J ) )
$ M = M + 1
10 CONTINUE
ELSE
M = N
END IF
*
INFO = 0
NB = ILAENV( 1, 'ZTREVC', SIDE // HOWMNY, N, -1, -1, -1 )
MAXWRK = N + 2*N*NB
WORK(1) = MAXWRK
RWORK(1) = N
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -1
ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
INFO = -8
ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
INFO = -10
ELSE IF( MM.LT.M ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
INFO = -14
ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -16
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREVC3', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible.
*
IF( N.EQ.0 )
$ RETURN
*
* Use blocked version of back-transformation if sufficient workspace.
* Zero-out the workspace to avoid potential NaN propagation.
*
IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN
NB = (LWORK - N) / (2*N)
NB = MIN( NB, NBMAX )
CALL ZLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N )
ELSE
NB = 1
END IF
*
* Set the constants to control overflow.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( N / ULP )
*
* Store the diagonal elements of T in working array WORK.
*
DO 20 I = 1, N
WORK( I ) = T( I, I )
20 CONTINUE
*
* Compute 1-norm of each column of strictly upper triangular
* part of T to control overflow in triangular solver.
*
RWORK( 1 ) = ZERO
DO 30 J = 2, N
RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 )
30 CONTINUE
*
IF( RIGHTV ) THEN
*
* ============================================================
* Compute right eigenvectors.
*
* IV is index of column in current block.
* Non-blocked version always uses IV=NB=1;
* blocked version starts with IV=NB, goes down to 1.
* (Note the "0-th" column is used to store the original diagonal.)
IV = NB
IS = M
DO 80 KI = N, 1, -1
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 80
END IF
SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
* --------------------------------------------------------
* Complex right eigenvector
*
WORK( KI + IV*N ) = CONE
*
* Form right-hand side.
*
DO 40 K = 1, KI - 1
WORK( K + IV*N ) = -T( K, KI )
40 CONTINUE
*
* Solve upper triangular system:
* [ T(1:KI-1,1:KI-1) - T(KI,KI) ]*X = SCALE*WORK.
*
DO 50 K = 1, KI - 1
T( K, K ) = T( K, K ) - T( KI, KI )
IF( CABS1( T( K, K ) ).LT.SMIN )
$ T( K, K ) = SMIN
50 CONTINUE
*
IF( KI.GT.1 ) THEN
CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
$ KI-1, T, LDT, WORK( 1 + IV*N ), SCALE,
$ RWORK, INFO )
WORK( KI + IV*N ) = SCALE
END IF
*
* Copy the vector x or Q*x to VR and normalize.
*
IF( .NOT.OVER ) THEN
* ------------------------------
* no back-transform: copy x to VR and normalize.
CALL ZCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 )
*
II = IZAMAX( KI, VR( 1, IS ), 1 )
REMAX = ONE / CABS1( VR( II, IS ) )
CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 )
*
DO 60 K = KI + 1, N
VR( K, IS ) = CZERO
60 CONTINUE
*
ELSE IF( NB.EQ.1 ) THEN
* ------------------------------
* version 1: back-transform each vector with GEMV, Q*x.
IF( KI.GT.1 )
$ CALL ZGEMV( 'N', N, KI-1, CONE, VR, LDVR,
$ WORK( 1 + IV*N ), 1, DCMPLX( SCALE ),
$ VR( 1, KI ), 1 )
*
II = IZAMAX( N, VR( 1, KI ), 1 )
REMAX = ONE / CABS1( VR( II, KI ) )
CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 )
*
ELSE
* ------------------------------
* version 2: back-transform block of vectors with GEMM
* zero out below vector
DO K = KI + 1, N
WORK( K + IV*N ) = CZERO
END DO
*
* Columns IV:NB of work are valid vectors.
* When the number of vectors stored reaches NB,
* or if this was last vector, do the GEMM
IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN
CALL ZGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE,
$ VR, LDVR,
$ WORK( 1 + (IV)*N ), N,
$ CZERO,
$ WORK( 1 + (NB+IV)*N ), N )
* normalize vectors
DO K = IV, NB
II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
END DO
CALL ZLACPY( 'F', N, NB-IV+1,
$ WORK( 1 + (NB+IV)*N ), N,
$ VR( 1, KI ), LDVR )
IV = NB
ELSE
IV = IV - 1
END IF
END IF
*
* Restore the original diagonal elements of T.
*
DO 70 K = 1, KI - 1
T( K, K ) = WORK( K )
70 CONTINUE
*
IS = IS - 1
80 CONTINUE
END IF
*
IF( LEFTV ) THEN
*
* ============================================================
* Compute left eigenvectors.
*
* IV is index of column in current block.
* Non-blocked version always uses IV=1;
* blocked version starts with IV=1, goes up to NB.
* (Note the "0-th" column is used to store the original diagonal.)
IV = 1
IS = 1
DO 130 KI = 1, N
*
IF( SOMEV ) THEN
IF( .NOT.SELECT( KI ) )
$ GO TO 130
END IF
SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
*
* --------------------------------------------------------
* Complex left eigenvector
*
WORK( KI + IV*N ) = CONE
*
* Form right-hand side.
*
DO 90 K = KI + 1, N
WORK( K + IV*N ) = -CONJG( T( KI, K ) )
90 CONTINUE
*
* Solve conjugate-transposed triangular system:
* [ T(KI+1:N,KI+1:N) - T(KI,KI) ]**H * X = SCALE*WORK.
*
DO 100 K = KI + 1, N
T( K, K ) = T( K, K ) - T( KI, KI )
IF( CABS1( T( K, K ) ).LT.SMIN )
$ T( K, K ) = SMIN
100 CONTINUE
*
IF( KI.LT.N ) THEN
CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
$ 'Y', N-KI, T( KI+1, KI+1 ), LDT,
$ WORK( KI+1 + IV*N ), SCALE, RWORK, INFO )
WORK( KI + IV*N ) = SCALE
END IF
*
* Copy the vector x or Q*x to VL and normalize.
*
IF( .NOT.OVER ) THEN
* ------------------------------
* no back-transform: copy x to VL and normalize.
CALL ZCOPY( N-KI+1, WORK( KI + IV*N ), 1, VL(KI,IS), 1 )
*
II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
REMAX = ONE / CABS1( VL( II, IS ) )
CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
*
DO 110 K = 1, KI - 1
VL( K, IS ) = CZERO
110 CONTINUE
*
ELSE IF( NB.EQ.1 ) THEN
* ------------------------------
* version 1: back-transform each vector with GEMV, Q*x.
IF( KI.LT.N )
$ CALL ZGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ), LDVL,
$ WORK( KI+1 + IV*N ), 1, DCMPLX( SCALE ),
$ VL( 1, KI ), 1 )
*
II = IZAMAX( N, VL( 1, KI ), 1 )
REMAX = ONE / CABS1( VL( II, KI ) )
CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 )
*
ELSE
* ------------------------------
* version 2: back-transform block of vectors with GEMM
* zero out above vector
* could go from KI-NV+1 to KI-1
DO K = 1, KI - 1
WORK( K + IV*N ) = CZERO
END DO
*
* Columns 1:IV of work are valid vectors.
* When the number of vectors stored reaches NB,
* or if this was last vector, do the GEMM
IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN
CALL ZGEMM( 'N', 'N', N, IV, N-KI+IV, CONE,
$ VL( 1, KI-IV+1 ), LDVL,
$ WORK( KI-IV+1 + (1)*N ), N,
$ CZERO,
$ WORK( 1 + (NB+1)*N ), N )
* normalize vectors
DO K = 1, IV
II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 )
REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) )
CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 )
END DO
CALL ZLACPY( 'F', N, IV,
$ WORK( 1 + (NB+1)*N ), N,
$ VL( 1, KI-IV+1 ), LDVL )
IV = 1
ELSE
IV = IV + 1
END IF
END IF
*
* Restore the original diagonal elements of T.
*
DO 120 K = KI + 1, N
T( K, K ) = WORK( K )
120 CONTINUE
*
IS = IS + 1
130 CONTINUE
END IF
*
RETURN
*
* End of ZTREVC3
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhseqr.f 0000644 0000000 0000000 00000000132 14061636515 015340 x ustar 00 30 mtime=1623670093.186104097
30 atime=1623670093.185104098
30 ctime=1623670093.186104097
elk-7.2.42/src/LAPACK/zhseqr.f 0000644 0025044 0025044 00000042757 14061636515 017414 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHSEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHSEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
* CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHSEQR computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> = 'E': compute eigenvalues only;
*> = 'S': compute eigenvalues and the Schur form T.
*> \endverbatim
*>
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': no Schur vectors are computed;
*> = 'I': Z is initialized to the unit matrix and the matrix Z
*> of Schur vectors of H is returned;
*> = 'V': Z must contain an unitary matrix Q on entry, and
*> the product Q*Z is returned.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL, and then passed to ZGEHRD
*> when the matrix output by ZGEBAL is reduced to Hessenberg
*> form. Otherwise ILO and IHI should be set to 1 and N
*> respectively. If N > 0, then 1 <= ILO <= IHI <= N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and JOB = 'S', H contains the upper
*> triangular matrix T from the Schur decomposition (the
*> Schur form). If INFO = 0 and JOB = 'E', the contents of
*> H are unspecified on exit. (The output value of H when
*> INFO > 0 is given under the description of INFO below.)
*>
*> Unlike earlier versions of ZHSEQR, this subroutine may
*> explicitly H(i,j) = 0 for i > j and j = 1, 2, ... ILO-1
*> or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues. If JOB = 'S', the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If COMPZ = 'N', Z is not referenced.
*> If COMPZ = 'I', on entry Z need not be set and on exit,
*> if INFO = 0, Z contains the unitary matrix Z of the Schur
*> vectors of H. If COMPZ = 'V', on entry Z must contain an
*> N-by-N matrix Q, which is assumed to be equal to the unit
*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
*> if INFO = 0, Z contains Q*Z.
*> Normally Q is the unitary matrix generated by ZUNGHR
*> after the call to ZGEHRD which formed the Hessenberg matrix
*> H. (The output value of Z when INFO > 0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if COMPZ = 'I' or
*> COMPZ = 'V', then LDZ >= MAX(1,N). Otherwise, LDZ >= 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, if INFO = 0, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N)
*> is sufficient and delivers very good and sometimes
*> optimal performance. However, LWORK as large as 11*N
*> may be required for optimal performance. A workspace
*> query is recommended to determine the optimal workspace
*> size.
*>
*> If LWORK = -1, then ZHSEQR does a workspace query.
*> In this case, ZHSEQR checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal
*> value
*> > 0: if INFO = i, ZHSEQR failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of W
*> contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO > 0 and JOB = 'E', then on exit, the
*> remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO > 0 and JOB = 'S', then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO > 0 and COMPZ = 'V', then on exit
*>
*> (final value of Z) = (initial value of Z)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO > 0 and COMPZ = 'I', then on exit
*> (final value of Z) = U
*> where U is the unitary matrix in (*) (regard-
*> less of the value of JOB.)
*>
*> If INFO > 0 and COMPZ = 'N', then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Default values supplied by
*> ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
*> It is suggested that these defaults be adjusted in order
*> to attain best performance in each particular
*> computational environment.
*>
*> ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
*> Default: 75. (Must be at least 11.)
*>
*> ISPEC=13: Recommended deflation window size.
*> This depends on ILO, IHI and NS. NS is the
*> number of simultaneous shifts returned
*> by ILAENV(ISPEC=15). (See ISPEC=15 below.)
*> The default for (IHI-ILO+1) <= 500 is NS.
*> The default for (IHI-ILO+1) > 500 is 3*NS/2.
*>
*> ISPEC=14: Nibble crossover point. (See IPARMQ for
*> details.) Default: 14% of deflation window
*> size.
*>
*> ISPEC=15: Number of simultaneous shifts in a multishift
*> QR iteration.
*>
*> If IHI-ILO+1 is ...
*>
*> greater than ...but less ... the
*> or equal to ... than default is
*>
*> 1 30 NS = 2(+)
*> 30 60 NS = 4(+)
*> 60 150 NS = 10(+)
*> 150 590 NS = **
*> 590 3000 NS = 64
*> 3000 6000 NS = 128
*> 6000 infinity NS = 256
*>
*> (+) By default some or all matrices of this order
*> are passed to the implicit double shift routine
*> ZLAHQR and this parameter is ignored. See
*> ISPEC=12 above and comments in IPARMQ for
*> details.
*>
*> (**) The asterisks (**) indicate an ad-hoc
*> function of N increasing from 10 to 64.
*>
*> ISPEC=16: Select structured matrix multiply.
*> If the number of simultaneous shifts (specified
*> by ISPEC=15) is less than 14, then the default
*> for ISPEC=16 is 0. Otherwise the default for
*> ISPEC=16 is 2.
*> \endverbatim
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*
* =====================================================================
SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
*
* -- LAPACK computational routine (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 IHI, ILO, INFO, LDH, LDZ, LWORK, N
CHARACTER COMPZ, JOB
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== NL allocates some local workspace to help small matrices
* . through a rare ZLAHQR failure. NL > NTINY = 11 is
* . required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom-
* . mended. (The default value of NMIN is 75.) Using NL = 49
* . allows up to six simultaneous shifts and a 16-by-16
* . deflation window. ====
INTEGER NL
PARAMETER ( NL = 49 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0d0 )
* ..
* .. Local Arrays ..
COMPLEX*16 HL( NL, NL ), WORKL( NL )
* ..
* .. Local Scalars ..
INTEGER KBOT, NMIN
LOGICAL INITZ, LQUERY, WANTT, WANTZ
* ..
* .. External Functions ..
INTEGER ILAENV
LOGICAL LSAME
EXTERNAL ILAENV, LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, MAX, MIN
* ..
* .. Executable Statements ..
*
* ==== Decode and check the input parameters. ====
*
WANTT = LSAME( JOB, 'S' )
INITZ = LSAME( COMPZ, 'I' )
WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO )
LQUERY = LWORK.EQ.-1
*
INFO = 0
IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.NE.0 ) THEN
*
* ==== Quick return in case of invalid argument. ====
*
CALL XERBLA( 'ZHSEQR', -INFO )
RETURN
*
ELSE IF( N.EQ.0 ) THEN
*
* ==== Quick return in case N = 0; nothing to do. ====
*
RETURN
*
ELSE IF( LQUERY ) THEN
*
* ==== Quick return in case of a workspace query ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
$ LDZ, WORK, LWORK, INFO )
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1,
$ N ) ) ), RZERO )
RETURN
*
ELSE
*
* ==== copy eigenvalues isolated by ZGEBAL ====
*
IF( ILO.GT.1 )
$ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 )
IF( IHI.LT.N )
$ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
*
* ==== Initialize Z, if requested ====
*
IF( INITZ )
$ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
*
* ==== Quick return if possible ====
*
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
$ ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
*
IF( N.GT.NMIN ) THEN
CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, WORK, LWORK, INFO )
ELSE
*
* ==== Small matrix ====
*
CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
$ Z, LDZ, INFO )
*
IF( INFO.GT.0 ) THEN
*
* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds
* . when ZLAHQR fails. ====
*
KBOT = INFO
*
IF( N.GE.NL ) THEN
*
* ==== Larger matrices have enough subdiagonal scratch
* . space to call ZLAQR0 directly. ====
*
CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
$ ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
*
ELSE
*
* ==== Tiny matrices don't have enough subdiagonal
* . scratch space to benefit from ZLAQR0. Hence,
* . tiny matrices must be copied into a larger
* . array before calling ZLAQR0. ====
*
CALL ZLACPY( 'A', N, N, H, LDH, HL, NL )
HL( N+1, N ) = ZERO
CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
$ NL )
CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
$ ILO, IHI, Z, LDZ, WORKL, NL, INFO )
IF( WANTT .OR. INFO.NE.0 )
$ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH )
END IF
END IF
END IF
*
* ==== Clear out the trash, if necessary. ====
*
IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
$ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
*
* ==== Ensure reported workspace size is backward-compatible with
* . previous LAPACK versions. ====
*
WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ),
$ DBLE( WORK( 1 ) ) ), RZERO )
END IF
*
* ==== End of ZHSEQR ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlabad.f 0000644 0000000 0000000 00000000132 14061636515 015233 x ustar 00 30 mtime=1623670093.188104095
30 atime=1623670093.187104096
30 ctime=1623670093.188104095
elk-7.2.42/src/LAPACK/dlabad.f 0000644 0025044 0025044 00000006015 14061636515 017272 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLABAD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLABAD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLABAD( SMALL, LARGE )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION LARGE, SMALL
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLABAD takes as input the values computed by DLAMCH for underflow and
*> overflow, and returns the square root of each of these values if the
*> log of LARGE is sufficiently large. This subroutine is intended to
*> identify machines with a large exponent range, such as the Crays, and
*> redefine the underflow and overflow limits to be the square roots of
*> the values computed by DLAMCH. This subroutine is needed because
*> DLAMCH does not compensate for poor arithmetic in the upper half of
*> the exponent range, as is found on a Cray.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in,out] SMALL
*> \verbatim
*> SMALL is DOUBLE PRECISION
*> On entry, the underflow threshold as computed by DLAMCH.
*> On exit, if LOG10(LARGE) is sufficiently large, the square
*> root of SMALL, otherwise unchanged.
*> \endverbatim
*>
*> \param[in,out] LARGE
*> \verbatim
*> LARGE is DOUBLE PRECISION
*> On entry, the overflow threshold as computed by DLAMCH.
*> On exit, if LOG10(LARGE) is sufficiently large, the square
*> root of LARGE, otherwise unchanged.
*> \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 DLABAD( SMALL, LARGE )
*
* -- 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 ..
DOUBLE PRECISION LARGE, SMALL
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC LOG10, SQRT
* ..
* .. Executable Statements ..
*
* If it looks like we're on a Cray, take the square root of
* SMALL and LARGE to avoid overflow and underflow problems.
*
IF( LOG10( LARGE ).GT.2000.D0 ) THEN
SMALL = SQRT( SMALL )
LARGE = SQRT( LARGE )
END IF
*
RETURN
*
* End of DLABAD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlange.f 0000644 0000000 0000000 00000000132 14061636515 015304 x ustar 00 30 mtime=1623670093.189104094
30 atime=1623670093.189104094
30 ctime=1623670093.189104094
elk-7.2.42/src/LAPACK/zlange.f 0000644 0025044 0025044 00000014160 14061636515 017343 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANGE returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> complex matrix A.
*> \endverbatim
*>
*> \return ZLANGE
*> \verbatim
*>
*> ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANGE as described
*> above.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0. When M = 0,
*> ZLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0. When N = 0,
*> ZLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(M,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*> referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
* -- 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
*
IMPLICIT NONE
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SUM, VALUE, TEMP
* ..
* .. Local Arrays ..
DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ, DCOMBSSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
TEMP = ABS( A( I, J ) )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
TEMP = WORK( I )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
* SSQ(1) is scale
* SSQ(2) is sum-of-squares
* For better accuracy, sum each column separately.
*
SSQ( 1 ) = ZERO
SSQ( 2 ) = ONE
DO 90 J = 1, N
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL ZLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
90 CONTINUE
VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
END IF
*
ZLANGE = VALUE
RETURN
*
* End of ZLANGE
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlascl.f 0000644 0000000 0000000 00000000132 14061636515 015314 x ustar 00 30 mtime=1623670093.191104092
30 atime=1623670093.191104092
30 ctime=1623670093.191104092
elk-7.2.42/src/LAPACK/zlascl.f 0000644 0025044 0025044 00000023435 14061636515 017360 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TYPE
* INTEGER INFO, KL, KU, LDA, M, N
* DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASCL multiplies the M by N complex matrix A by the real scalar
*> CTO/CFROM. This is done without over/underflow as long as the final
*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
*> A may be full, upper triangular, lower triangular, upper Hessenberg,
*> or banded.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TYPE
*> \verbatim
*> TYPE is CHARACTER*1
*> TYPE indices the storage type of the input matrix.
*> = 'G': A is a full matrix.
*> = 'L': A is a lower triangular matrix.
*> = 'U': A is an upper triangular matrix.
*> = 'H': A is an upper Hessenberg matrix.
*> = 'B': A is a symmetric band matrix with lower bandwidth KL
*> and upper bandwidth KU and with the only the lower
*> half stored.
*> = 'Q': A is a symmetric band matrix with lower bandwidth KL
*> and upper bandwidth KU and with the only the upper
*> half stored.
*> = 'Z': A is a band matrix with lower bandwidth KL and upper
*> bandwidth KU. See ZGBTRF for storage details.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The lower bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The upper bandwidth of A. Referenced only if TYPE = 'B',
*> 'Q' or 'Z'.
*> \endverbatim
*>
*> \param[in] CFROM
*> \verbatim
*> CFROM is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] CTO
*> \verbatim
*> CTO is DOUBLE PRECISION
*>
*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
*> without over/underflow if the final result CTO*A(I,J)/CFROM
*> can be represented without over/underflow. CFROM must be
*> nonzero.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The matrix to be multiplied by CTO/CFROM. See TYPE for the
*> storage type.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> 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 complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASCL( 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
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
ELSE IF( DISNAN(CTO) ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
IF( CFROM1.EQ.CFROMC ) THEN
! CFROMC is an inf. Multiply by a correctly signed zero for
! finite CTOC, or a NaN if CTOC is infinite.
MUL = CTOC / CFROMC
DONE = .TRUE.
CTO1 = CTOC
ELSE
CTO1 = CTOC / BIGNUM
IF( CTO1.EQ.CTOC ) THEN
! CTOC is either 0 or an inf. In both cases, CTOC itself
! serves as the correct multiplication factor.
MUL = CTOC
DONE = .TRUE.
CFROMC = ONE
ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of ZLASCL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgebal.f 0000644 0000000 0000000 00000000127 14061636515 015274 x ustar 00 29 mtime=1623670093.19310409
29 atime=1623670093.19310409
29 ctime=1623670093.19310409
elk-7.2.42/src/LAPACK/zgebal.f 0000644 0025044 0025044 00000024716 14061636515 017337 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEBAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB
* INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION SCALE( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBAL balances a general complex matrix A. This involves, first,
*> permuting A by a similarity transformation to isolate eigenvalues
*> in the first 1 to ILO-1 and last IHI+1 to N elements on the
*> diagonal; and second, applying a diagonal similarity transformation
*> to rows and columns ILO to IHI to make the rows and columns as
*> close in norm as possible. Both steps are optional.
*>
*> Balancing may reduce the 1-norm of the matrix, and improve the
*> accuracy of the computed eigenvalues and/or eigenvectors.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies the operations to be performed on A:
*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
*> for i = 1,...,N;
*> = 'P': permute only;
*> = 'S': scale only;
*> = 'B': both permute and scale.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the input matrix A.
*> On exit, A is overwritten by the balanced matrix.
*> If JOB = 'N', A is not referenced.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*> IHI is INTEGER
*> ILO and IHI are set to INTEGER such that on exit
*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
*> If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutations and scaling factors applied to
*> A. If P(j) is the index of the row and column interchanged
*> with row and column j and D(j) is the scaling factor
*> applied to row and column j, then
*> SCALE(j) = P(j) for j = 1,...,ILO-1
*> = D(j) for j = ILO,...,IHI
*> = P(j) for j = IHI+1,...,N.
*> The order in which the interchanges are made is N to IHI+1,
*> then 1 to ILO-1.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The permutations consist of row and column interchanges which put
*> the matrix in the form
*>
*> ( T1 X Y )
*> P A P = ( 0 B Z )
*> ( 0 0 T2 )
*>
*> where T1 and T2 are upper triangular matrices whose eigenvalues lie
*> along the diagonal. The column indices ILO and IHI mark the starting
*> and ending columns of the submatrix B. Balancing consists of applying
*> a diagonal similarity transformation inv(D) * B * D to make the
*> 1-norms of each row of B and its corresponding column nearly equal.
*> The output matrix is
*>
*> ( T1 X*D Y )
*> ( 0 inv(D)*B*D inv(D)*Z ).
*> ( 0 0 T2 )
*>
*> Information about the permutations P and the diagonal matrix D is
*> returned in the vector SCALE.
*>
*> This subroutine is based on the EISPACK routine CBAL.
*>
*> Modified by Tzu-Yi Chen, Computer Science Division, University of
*> California at Berkeley, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK computational routine (version 3.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 ..
CHARACTER JOB
INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SCALE( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION SCLFAC
PARAMETER ( SCLFAC = 2.0D+0 )
DOUBLE PRECISION FACTOR
PARAMETER ( FACTOR = 0.95D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOCONV
INTEGER I, ICA, IEXC, IRA, J, K, L, M
DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
$ SFMIN2
* ..
* .. External Functions ..
LOGICAL DISNAN, LSAME
INTEGER IZAMAX
DOUBLE PRECISION DLAMCH, DZNRM2
EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG, MAX, MIN
*
* Test the input parameters
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEBAL', -INFO )
RETURN
END IF
*
K = 1
L = N
*
IF( N.EQ.0 )
$ GO TO 210
*
IF( LSAME( JOB, 'N' ) ) THEN
DO 10 I = 1, N
SCALE( I ) = ONE
10 CONTINUE
GO TO 210
END IF
*
IF( LSAME( JOB, 'S' ) )
$ GO TO 120
*
* Permutation to isolate eigenvalues if possible
*
GO TO 50
*
* Row and column exchange.
*
20 CONTINUE
SCALE( M ) = J
IF( J.EQ.M )
$ GO TO 30
*
CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
*
30 CONTINUE
GO TO ( 40, 80 )IEXC
*
* Search for rows isolating an eigenvalue and push them down.
*
40 CONTINUE
IF( L.EQ.1 )
$ GO TO 210
L = L - 1
*
50 CONTINUE
DO 70 J = L, 1, -1
*
DO 60 I = 1, L
IF( I.EQ.J )
$ GO TO 60
IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE.
$ ZERO )GO TO 70
60 CONTINUE
*
M = L
IEXC = 1
GO TO 20
70 CONTINUE
*
GO TO 90
*
* Search for columns isolating an eigenvalue and push them left.
*
80 CONTINUE
K = K + 1
*
90 CONTINUE
DO 110 J = K, L
*
DO 100 I = K, L
IF( I.EQ.J )
$ GO TO 100
IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE.
$ ZERO )GO TO 110
100 CONTINUE
*
M = K
IEXC = 2
GO TO 20
110 CONTINUE
*
120 CONTINUE
DO 130 I = K, L
SCALE( I ) = ONE
130 CONTINUE
*
IF( LSAME( JOB, 'P' ) )
$ GO TO 210
*
* Balance the submatrix in rows K to L.
*
* Iterative loop for norm reduction
*
SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
SFMAX1 = ONE / SFMIN1
SFMIN2 = SFMIN1*SCLFAC
SFMAX2 = ONE / SFMIN2
140 CONTINUE
NOCONV = .FALSE.
*
DO 200 I = K, L
*
C = DZNRM2( L-K+1, A( K, I ), 1 )
R = DZNRM2( L-K+1, A( I, K ), LDA )
ICA = IZAMAX( L, A( 1, I ), 1 )
CA = ABS( A( ICA, I ) )
IRA = IZAMAX( N-K+1, A( I, K ), LDA )
RA = ABS( A( I, IRA+K-1 ) )
*
* Guard against zero C or R due to underflow.
*
IF( C.EQ.ZERO .OR. R.EQ.ZERO )
$ GO TO 200
G = R / SCLFAC
F = ONE
S = C + R
160 CONTINUE
IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
$ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
IF( DISNAN( C+F+CA+R+G+RA ) ) THEN
*
* Exit if NaN to avoid infinite loop
*
INFO = -3
CALL XERBLA( 'ZGEBAL', -INFO )
RETURN
END IF
F = F*SCLFAC
C = C*SCLFAC
CA = CA*SCLFAC
R = R / SCLFAC
G = G / SCLFAC
RA = RA / SCLFAC
GO TO 160
*
170 CONTINUE
G = C / SCLFAC
180 CONTINUE
IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
$ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
F = F / SCLFAC
C = C / SCLFAC
G = G / SCLFAC
CA = CA / SCLFAC
R = R*SCLFAC
RA = RA*SCLFAC
GO TO 180
*
* Now balance.
*
190 CONTINUE
IF( ( C+R ).GE.FACTOR*S )
$ GO TO 200
IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
IF( F*SCALE( I ).LE.SFMIN1 )
$ GO TO 200
END IF
IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
IF( SCALE( I ).GE.SFMAX1 / F )
$ GO TO 200
END IF
G = ONE / F
SCALE( I ) = SCALE( I )*F
NOCONV = .TRUE.
*
CALL ZDSCAL( N-K+1, G, A( I, K ), LDA )
CALL ZDSCAL( L, F, A( 1, I ), 1 )
*
200 CONTINUE
*
IF( NOCONV )
$ GO TO 140
*
210 CONTINUE
ILO = K
IHI = L
*
RETURN
*
* End of ZGEBAL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgehrd.f 0000644 0000000 0000000 00000000132 14061636515 015307 x ustar 00 30 mtime=1623670093.195104088
30 atime=1623670093.195104088
30 ctime=1623670093.195104088
elk-7.2.42/src/LAPACK/zgehrd.f 0000644 0025044 0025044 00000025255 14061636515 017355 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEHRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEHRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
*> an unitary similarity transformation: Q**H * A * Q = H .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that A is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL; otherwise they should be
*> set to 1 and N respectively. See Further Details.
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the N-by-N general matrix to be reduced.
*> On exit, the upper triangle and the first subdiagonal of A
*> are overwritten with the upper Hessenberg matrix H, and the
*> elements below the first subdiagonal, with the array TAU,
*> represent the unitary matrix Q as a product of elementary
*> reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
*> zero.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,N).
*> For 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.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of (ihi-ilo) elementary
*> reflectors
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*> exit in A(i+2:ihi,i), and tau in TAU(i).
*>
*> The contents of A are illustrated by the following example, with
*> n = 7, ilo = 2 and ihi = 6:
*>
*> on entry, on exit,
*>
*> ( a a a a a a a ) ( a a h h h h a )
*> ( a a a a a a ) ( a h h h h a )
*> ( a a a a a a ) ( h h h h h h )
*> ( a a a a a a ) ( v2 h h h h h )
*> ( a a a a a a ) ( v2 v3 h h h h )
*> ( a a a a a a ) ( v2 v3 v4 h h h )
*> ( a ) ( a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*>
*> This file is a slight modification of LAPACK-3.0's DGEHRD
*> subroutine incorporating improvements proposed by Quintana-Orti and
*> Van de Geijn (2006). (See DLAHR2.)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.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 IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB,
$ NBMIN, NH, NX
COMPLEX*16 EI
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
LWKOPT = N*NB + TSIZE
WORK( 1 ) = LWKOPT
ENDIF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEHRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
*
DO 10 I = 1, ILO - 1
TAU( I ) = ZERO
10 CONTINUE
DO 20 I = MAX( 1, IHI ), N - 1
TAU( I ) = ZERO
20 CONTINUE
*
* Quick return if possible
*
NH = IHI - ILO + 1
IF( NH.LE.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size
*
NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
NBMIN = 2
IF( NB.GT.1 .AND. NB.LT.NH ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code)
*
NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
IF( NX.LT.NH ) THEN
*
* Determine if workspace is large enough for blocked code
*
IF( LWORK.LT.N*NB+TSIZE ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code
*
NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI,
$ -1 ) )
IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN
NB = (LWORK-TSIZE) / N
ELSE
NB = 1
END IF
END IF
END IF
END IF
LDWORK = N
*
IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
*
* Use unblocked code below
*
I = ILO
*
ELSE
*
* Use blocked code
*
IWT = 1 + N*NB
DO 40 I = ILO, IHI - 1 - NX, NB
IB = MIN( NB, IHI-I )
*
* Reduce columns i:i+ib-1 to Hessenberg form, returning the
* matrices V and T of the block reflector H = I - V*T*V**H
* which performs the reduction, and also the matrix Y = A*V*T
*
CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ),
$ WORK( IWT ), LDT, WORK, LDWORK )
*
* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set
* to 1
*
EI = A( I+IB, I+IB-1 )
A( I+IB, I+IB-1 ) = ONE
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ IHI, IHI-I-IB+1,
$ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
$ A( 1, I+IB ), LDA )
A( I+IB, I+IB-1 ) = EI
*
* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
* right
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', I, IB-1,
$ ONE, A( I+1, I ), LDA, WORK, LDWORK )
DO 30 J = 0, IB-2
CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
$ A( 1, I+J+1 ), 1 )
30 CONTINUE
*
* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
* left
*
CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
$ 'Columnwise',
$ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA,
$ WORK( IWT ), LDT, A( I+1, I+IB ), LDA,
$ WORK, LDWORK )
40 CONTINUE
END IF
*
* Use unblocked code to reduce the rest of the matrix
*
CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZGEHRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlacpy.f 0000644 0000000 0000000 00000000132 14061636515 015326 x ustar 00 30 mtime=1623670093.197104087
30 atime=1623670093.197104087
30 ctime=1623670093.197104087
elk-7.2.42/src/LAPACK/zlacpy.f 0000644 0025044 0025044 00000007754 14061636515 017400 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLACPY copies all or part of one two-dimensional array to another.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACPY copies all or part of a two-dimensional matrix A to another
*> matrix B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be copied to B.
*> = 'U': Upper triangular part
*> = 'L': Lower triangular part
*> Otherwise: All of the matrix A
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A. If UPLO = 'U', only the upper trapezium
*> is accessed; if UPLO = 'L', only the lower trapezium is
*> accessed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> On exit, B = A in the locations specified by UPLO.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACPY( 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 ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
*
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
RETURN
*
* End of ZLACPY
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunghr.f 0000644 0000000 0000000 00000000132 14061636515 015341 x ustar 00 30 mtime=1623670093.199104085
30 atime=1623670093.198104086
30 ctime=1623670093.199104085
elk-7.2.42/src/LAPACK/zunghr.f 0000644 0025044 0025044 00000014707 14061636515 017407 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGHR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGHR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGHR generates a complex unitary matrix Q which is defined as the
*> product of IHI-ILO elementary reflectors of order N, as returned by
*> ZGEHRD:
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> ILO and IHI must have the same values as in the previous call
*> of ZGEHRD. Q is equal to the unit matrix except in the
*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZGEHRD.
*> On exit, the N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEHRD.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= IHI-ILO.
*> For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, 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 IHI, ILO, INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LWKOPT, NB, NH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGQR
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LQUERY = ( LWORK.EQ.-1 )
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
*
IF( INFO.EQ.0 ) THEN
NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 )
LWKOPT = MAX( 1, NH )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first ilo and the last n-ihi
* rows and columns to those of the unit matrix
*
DO 40 J = IHI, ILO + 1, -1
DO 10 I = 1, J - 1
A( I, J ) = ZERO
10 CONTINUE
DO 20 I = J + 1, IHI
A( I, J ) = A( I, J-1 )
20 CONTINUE
DO 30 I = IHI + 1, N
A( I, J ) = ZERO
30 CONTINUE
40 CONTINUE
DO 60 J = 1, ILO
DO 50 I = 1, N
A( I, J ) = ZERO
50 CONTINUE
A( J, J ) = ONE
60 CONTINUE
DO 80 J = IHI + 1, N
DO 70 I = 1, N
A( I, J ) = ZERO
70 CONTINUE
A( J, J ) = ONE
80 CONTINUE
*
IF( NH.GT.0 ) THEN
*
* Generate Q(ilo+1:ihi,ilo+1:ihi)
*
CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
$ WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGHR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgebak.f 0000644 0000000 0000000 00000000132 14061636515 015267 x ustar 00 30 mtime=1623670093.200104084
30 atime=1623670093.200104084
30 ctime=1623670093.200104084
elk-7.2.42/src/LAPACK/zgebak.f 0000644 0025044 0025044 00000016157 14061636515 017336 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEBAK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAK + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOB, SIDE
* INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION SCALE( * )
* COMPLEX*16 V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBAK forms the right or left eigenvectors of a complex general
*> matrix by backward transformation on the computed eigenvectors of the
*> balanced matrix output by ZGEBAL.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is CHARACTER*1
*> Specifies the type of backward transformation required:
*> = 'N': do nothing, return immediately;
*> = 'P': do backward transformation for permutation only;
*> = 'S': do backward transformation for scaling only;
*> = 'B': do backward transformations for both permutation and
*> scaling.
*> JOB must be the same as the argument JOB supplied to ZGEBAL.
*> \endverbatim
*>
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'R': V contains right eigenvectors;
*> = 'L': V contains left eigenvectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows of the matrix V. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> The integers ILO and IHI determined by ZGEBAL.
*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*> \endverbatim
*>
*> \param[in] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION array, dimension (N)
*> Details of the permutation and scaling factors, as returned
*> by ZGEBAL.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of columns of the matrix V. M >= 0.
*> \endverbatim
*>
*> \param[in,out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,M)
*> On entry, the matrix of right or left eigenvectors to be
*> transformed, as returned by ZHSEIN or ZTREVC.
*> On exit, V is overwritten by the transformed eigenvectors.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V. LDV >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ 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 JOB, SIDE
INTEGER IHI, ILO, INFO, LDV, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SCALE( * )
COMPLEX*16 V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFTV, RIGHTV
INTEGER I, II, K
DOUBLE PRECISION S
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZDSCAL, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Decode and Test the input parameters
*
RIGHTV = LSAME( SIDE, 'R' )
LEFTV = LSAME( SIDE, 'L' )
*
INFO = 0
IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
$ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
INFO = -1
ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -5
ELSE IF( M.LT.0 ) THEN
INFO = -7
ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEBAK', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( M.EQ.0 )
$ RETURN
IF( LSAME( JOB, 'N' ) )
$ RETURN
*
IF( ILO.EQ.IHI )
$ GO TO 30
*
* Backward balance
*
IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
IF( RIGHTV ) THEN
DO 10 I = ILO, IHI
S = SCALE( I )
CALL ZDSCAL( M, S, V( I, 1 ), LDV )
10 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 20 I = ILO, IHI
S = ONE / SCALE( I )
CALL ZDSCAL( M, S, V( I, 1 ), LDV )
20 CONTINUE
END IF
*
END IF
*
* Backward permutation
*
* For I = ILO-1 step -1 until 1,
* IHI+1 step 1 until N do --
*
30 CONTINUE
IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
IF( RIGHTV ) THEN
DO 40 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 40
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 40
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
40 CONTINUE
END IF
*
IF( LEFTV ) THEN
DO 50 II = 1, N
I = II
IF( I.GE.ILO .AND. I.LE.IHI )
$ GO TO 50
IF( I.LT.ILO )
$ I = ILO - II
K = SCALE( I )
IF( K.EQ.I )
$ GO TO 50
CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
50 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZGEBAK
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgeqrf.f 0000644 0000000 0000000 00000000132 14061636515 015322 x ustar 00 30 mtime=1623670093.202104082
30 atime=1623670093.202104082
30 ctime=1623670093.202104082
elk-7.2.42/src/LAPACK/zgeqrf.f 0000644 0025044 0025044 00000017122 14061636515 017362 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEQRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
*>
*> A = Q * ( R ),
*> ( 0 )
*>
*> where:
*>
*> Q is a M-by-M orthogonal matrix;
*> R is an upper-triangular N-by-N matrix;
*> 0 is a (M-N)-by-N zero matrix, if M > N.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and above the diagonal of the array
*> contain the min(M,N)-by-N upper trapezoidal matrix R (R is
*> upper triangular if m >= n); the elements below the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of min(m,n) elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQRF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
K = MIN( M, N )
IF( K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code initially
*
DO 10 I = 1, K - NX, NB
IB = MIN( K-I+1, NB )
*
* Compute the QR factorization of the current block
* A(i:m,i:i+ib-1)
*
CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.N ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**H to A(i:m,i+ib:n) from the left
*
CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
ELSE
I = 1
END IF
*
* Use unblocked code to factor the last or only block.
*
IF( I.LE.K )
$ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGEQRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zungqr.f 0000644 0000000 0000000 00000000127 14061636515 015356 x ustar 00 29 mtime=1623670093.20410408
29 atime=1623670093.20410408
29 ctime=1623670093.20410408
elk-7.2.42/src/LAPACK/zungqr.f 0000644 0025044 0025044 00000017610 14061636515 017414 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
*> which is defined as the first N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQRF in the first k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, 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, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, N )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(1:kk,kk+1:n) to zero.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.N )
$ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.N ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i:m,i+ib:n) from the left
*
CALL ZLARFB( 'Left', 'No transpose', 'Forward',
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows i:m of current block
*
CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set rows 1:i-1 of current block to zero
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgebrd.f 0000644 0000000 0000000 00000000132 14061636515 015301 x ustar 00 30 mtime=1623670093.206104078
30 atime=1623670093.205104079
30 ctime=1623670093.206104078
elk-7.2.42/src/LAPACK/zgebrd.f 0000644 0025044 0025044 00000025740 14061636515 017346 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEBRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
*> bidiagonal form B by a unitary transformation: Q**H * A * P = B.
*>
*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N general matrix to be reduced.
*> On exit,
*> if m >= n, the diagonal and the first superdiagonal are
*> overwritten with the upper bidiagonal matrix B; the
*> elements below the diagonal, with the array TAUQ, represent
*> the unitary matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors;
*> if m < n, the diagonal and the first subdiagonal are
*> overwritten with the lower bidiagonal matrix B; the
*> elements below the first subdiagonal, with the array TAUQ,
*> represent the unitary matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (min(M,N))
*> The diagonal elements of the bidiagonal matrix B:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (min(M,N)-1)
*> The off-diagonal elements of the bidiagonal matrix B:
*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= max(1,M,N).
*> For optimum performance LWORK >= (M+N)*NB, where NB
*> is the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> If m >= n,
*>
*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
*> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n,
*>
*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The contents of A on exit are illustrated by the following examples:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
*> ( v1 v2 v3 v4 v5 )
*>
*> where d and e denote diagonal and off-diagonal elements of B, vi
*> denotes an element of the vector defining H(i), and ui an element of
*> the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
$ INFO )
*
* -- LAPACK computational routine (version 3.8.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
$ NBMIN, NX, WS
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
LWKOPT = ( M+N )*NB
WORK( 1 ) = DBLE( LWKOPT )
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
INFO = -10
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'ZGEBRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
MINMN = MIN( M, N )
IF( MINMN.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
WS = MAX( M, N )
LDWRKX = M
LDWRKY = N
*
IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
*
* Set the crossover point NX.
*
NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
*
* Determine when to switch from blocked to unblocked code.
*
IF( NX.LT.MINMN ) THEN
WS = ( M+N )*NB
IF( LWORK.LT.WS ) THEN
*
* Not enough work space for the optimal NB, consider using
* a smaller block size.
*
NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 )
IF( LWORK.GE.( M+N )*NBMIN ) THEN
NB = LWORK / ( M+N )
ELSE
NB = 1
NX = MINMN
END IF
END IF
END IF
ELSE
NX = MINMN
END IF
*
DO 30 I = 1, MINMN - NX, NB
*
* Reduce rows and columns i:i+ib-1 to bidiagonal form and return
* the matrices X and Y which are needed to update the unreduced
* part of the matrix
*
CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
$ WORK( LDWRKX*NB+1 ), LDWRKY )
*
* Update the trailing submatrix A(i+ib:m,i+ib:n), using
* an update of the form A := A - V*Y**H - X*U**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1,
$ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA,
$ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
$ A( I+NB, I+NB ), LDA )
CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
$ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
$ ONE, A( I+NB, I+NB ), LDA )
*
* Copy diagonal and off-diagonal elements of B back into A
*
IF( M.GE.N ) THEN
DO 10 J = I, I + NB - 1
A( J, J ) = D( J )
A( J, J+1 ) = E( J )
10 CONTINUE
ELSE
DO 20 J = I, I + NB - 1
A( J, J ) = D( J )
A( J+1, J ) = E( J )
20 CONTINUE
END IF
30 CONTINUE
*
* Use unblocked code to reduce the remainder of the matrix
*
CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAUQ( I ), TAUP( I ), WORK, IINFO )
WORK( 1 ) = WS
RETURN
*
* End of ZGEBRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zungbr.f 0000644 0000000 0000000 00000000132 14061636515 015333 x ustar 00 30 mtime=1623670093.208104076
30 atime=1623670093.207104077
30 ctime=1623670093.208104076
elk-7.2.42/src/LAPACK/zungbr.f 0000644 0025044 0025044 00000023266 14061636515 017401 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER VECT
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGBR generates one of the complex unitary matrices Q or P**H
*> determined by ZGEBRD when reducing a complex matrix A to bidiagonal
*> form: A = Q * B * P**H. Q and P**H are defined as products of
*> elementary reflectors H(i) or G(i) respectively.
*>
*> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
*> is of order M:
*> if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
*> columns of Q, where m >= n >= k;
*> if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
*> M-by-M matrix.
*>
*> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
*> is of order N:
*> if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
*> rows of P**H, where n >= m >= k;
*> if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
*> an N-by-N matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] VECT
*> \verbatim
*> VECT is CHARACTER*1
*> Specifies whether the matrix Q or the matrix P**H is
*> required, as defined in the transformation applied by ZGEBRD:
*> = 'Q': generate Q;
*> = 'P': generate P**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q or P**H to be returned.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q or P**H to be returned.
*> N >= 0.
*> If VECT = 'Q', M >= N >= min(M,K);
*> if VECT = 'P', N >= M >= min(N,K).
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> If VECT = 'Q', the number of columns in the original M-by-K
*> matrix reduced by ZGEBRD.
*> If VECT = 'P', the number of rows in the original K-by-N
*> matrix reduced by ZGEBRD.
*> K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZGEBRD.
*> On exit, the M-by-N matrix Q or P**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= M.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension
*> (min(M,K)) if VECT = 'Q'
*> (min(N,K)) if VECT = 'P'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i) or G(i), which determines Q or P**H, as
*> returned by ZGEBRD in its array argument TAUQ or TAUP.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,min(M,N)).
*> For optimum performance LWORK >= min(M,N)*NB, where NB
*> is the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex16GBcomputational
*
* =====================================================================
SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* April 2012
*
* .. Scalar Arguments ..
CHARACTER VECT
INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, WANTQ
INTEGER I, IINFO, J, LWKOPT, MN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGLQ, ZUNGQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
WANTQ = LSAME( VECT, 'Q' )
MN = MIN( M, N )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( M.LT.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
$ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
$ MIN( N, K ) ) ) ) THEN
INFO = -3
ELSE IF( K.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
WORK( 1 ) = 1
IF( WANTQ ) THEN
IF( M.GE.K ) THEN
CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( M.GT.1 ) THEN
CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ -1, IINFO )
END IF
END IF
ELSE
IF( K.LT.N ) THEN
CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
ELSE
IF( N.GT.1 ) THEN
CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ -1, IINFO )
END IF
END IF
END IF
LWKOPT = WORK( 1 )
LWKOPT = MAX (LWKOPT, MN)
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
WORK( 1 ) = LWKOPT
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( WANTQ ) THEN
*
* Form Q, determined by a call to ZGEBRD to reduce an m-by-k
* matrix
*
IF( M.GE.K ) THEN
*
* If m >= k, assume m >= n >= k
*
CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If m < k, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q
* to those of the unit matrix
*
DO 20 J = M, 2, -1
A( 1, J ) = ZERO
DO 10 I = J + 1, M
A( I, J ) = A( I, J-1 )
10 CONTINUE
20 CONTINUE
A( 1, 1 ) = ONE
DO 30 I = 2, M
A( I, 1 ) = ZERO
30 CONTINUE
IF( M.GT.1 ) THEN
*
* Form Q(2:m,2:m)
*
CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
ELSE
*
* Form P**H, determined by a call to ZGEBRD to reduce a k-by-n
* matrix
*
IF( K.LT.N ) THEN
*
* If k < n, assume k <= m <= n
*
CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* If k >= n, assume m = n
*
* Shift the vectors which define the elementary reflectors one
* row downward, and set the first row and column of P**H to
* those of the unit matrix
*
A( 1, 1 ) = ONE
DO 40 I = 2, N
A( I, 1 ) = ZERO
40 CONTINUE
DO 60 J = 2, N
DO 50 I = J - 1, 2, -1
A( I, J ) = A( I-1, J )
50 CONTINUE
A( 1, J ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Form P**H(2:n,2:n)
*
CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGBR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgelqf.f 0000644 0000000 0000000 00000000132 14061636515 015314 x ustar 00 30 mtime=1623670093.210104075
30 atime=1623670093.210104075
30 ctime=1623670093.210104075
elk-7.2.42/src/LAPACK/zgelqf.f 0000644 0025044 0025044 00000017056 14061636515 017362 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGELQF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELQF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
*>
*> A = ( L 0 ) * Q
*>
*> where:
*>
*> Q is a N-by-N orthogonal matrix;
*> L is an lower-triangular M-by-M matrix;
*> 0 is a M-by-(N-M) zero matrix, if M < N.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m-by-min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
*> A(i,i+1:n), and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
LWKOPT = M*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQF', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
K = MIN( M, N )
IF( K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1,
$ -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code initially
*
DO 10 I = 1, K - NX, NB
IB = MIN( K-I+1, NB )
*
* Compute the LQ factorization of the current block
* A(i:i+ib-1,i:n)
*
CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i+ib:m,i:n) from the right
*
CALL ZLARFB( 'Right', 'No transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
10 CONTINUE
ELSE
I = 1
END IF
*
* Use unblocked code to factor the last or only block.
*
IF( I.LE.K )
$ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
WORK( 1 ) = IWS
RETURN
*
* End of ZGELQF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunglq.f 0000644 0000000 0000000 00000000132 14061636515 015344 x ustar 00 30 mtime=1623670093.212104073
30 atime=1623670093.211104073
30 ctime=1623670093.212104073
elk-7.2.42/src/LAPACK/zunglq.f 0000644 0025044 0025044 00000017565 14061636515 017417 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
*> which is defined as the first M rows of a product of K elementary
*> reflectors of order N
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th row must contain the vector which defines
*> the elementary reflector H(i), for i = 1,2,...,k, as returned
*> by ZGELQF in the first k rows of its array argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,M).
*> For optimum performance LWORK >= M*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit;
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, 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, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, M )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = M
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = M
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk rows are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(kk+1:m,1:kk) to zero.
*
DO 20 J = 1, KK
DO 10 I = KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.M )
$ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.M ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK, LDWORK )
*
* Apply H**H to A(i+ib:m,i:n) from the right
*
CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward',
$ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
$ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H**H to columns i:n of current block
*
CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set columns 1:i-1 of current block to zero
*
DO 40 J = 1, I - 1
DO 30 L = I, I + IB - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGLQ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaset.f 0000644 0000000 0000000 00000000132 14061636515 015326 x ustar 00 30 mtime=1623670093.213104072
30 atime=1623670093.213104072
30 ctime=1623670093.213104072
elk-7.2.42/src/LAPACK/zlaset.f 0000644 0025044 0025044 00000011360 14061636515 017364 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASET initializes a 2-D array A to BETA on the diagonal and
*> ALPHA on the offdiagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be set.
*> = 'U': Upper triangular part is set. The lower triangle
*> is unchanged.
*> = 'L': Lower triangular part is set. The upper triangle
*> is unchanged.
*> Otherwise: All of the matrix A is set.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of A.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> All the offdiagonal array elements are set to ALPHA.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX*16
*> All the diagonal array elements are set to BETA.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
*> A(i,i) = BETA , 1 <= i <= min(m,n)
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASET( 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
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the diagonal to BETA and the strictly upper triangular
* part of the array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( N, M )
A( I, I ) = BETA
30 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the diagonal to BETA and the strictly lower triangular
* part of the array to ALPHA.
*
DO 50 J = 1, MIN( M, N )
DO 40 I = J + 1, M
A( I, J ) = ALPHA
40 CONTINUE
50 CONTINUE
DO 60 I = 1, MIN( N, M )
A( I, I ) = BETA
60 CONTINUE
*
ELSE
*
* Set the array to BETA on the diagonal and ALPHA on the
* offdiagonal.
*
DO 80 J = 1, N
DO 70 I = 1, M
A( I, J ) = ALPHA
70 CONTINUE
80 CONTINUE
DO 90 I = 1, MIN( M, N )
A( I, I ) = BETA
90 CONTINUE
END IF
*
RETURN
*
* End of ZLASET
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zbdsqr.f 0000644 0000000 0000000 00000000127 14061636515 015335 x ustar 00 29 mtime=1623670093.21510407
29 atime=1623670093.21510407
29 ctime=1623670093.21510407
elk-7.2.42/src/LAPACK/zbdsqr.f 0000644 0025044 0025044 00000062517 14061636515 017401 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZBDSQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZBDSQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
* LDU, C, LDC, RWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZBDSQR computes the singular values and, optionally, the right and/or
*> left singular vectors from the singular value decomposition (SVD) of
*> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
*> zero-shift QR algorithm. The SVD of B has the form
*>
*> B = Q * S * P**H
*>
*> where S is the diagonal matrix of singular values, Q is an orthogonal
*> matrix of left singular vectors, and P is an orthogonal matrix of
*> right singular vectors. If left singular vectors are requested, this
*> subroutine actually returns U*Q instead of Q, and, if right singular
*> vectors are requested, this subroutine returns P**H*VT instead of
*> P**H, for given complex input matrices U and VT. When U and VT are
*> the unitary matrices that reduce a general matrix A to bidiagonal
*> form: A = U*B*VT, as computed by ZGEBRD, then
*>
*> A = (U*Q) * S * (P**H*VT)
*>
*> is the SVD of A. Optionally, the subroutine may also compute Q**H*C
*> for a given complex input matrix C.
*>
*> See "Computing Small Singular Values of Bidiagonal Matrices With
*> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
*> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
*> no. 5, pp. 873-912, Sept 1990) and
*> "Accurate singular values and differential qd algorithms," by
*> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
*> Department, University of California at Berkeley, July 1992
*> for a detailed description of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': B is upper bidiagonal;
*> = 'L': B is lower bidiagonal.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix B. N >= 0.
*> \endverbatim
*>
*> \param[in] NCVT
*> \verbatim
*> NCVT is INTEGER
*> The number of columns of the matrix VT. NCVT >= 0.
*> \endverbatim
*>
*> \param[in] NRU
*> \verbatim
*> NRU is INTEGER
*> The number of rows of the matrix U. NRU >= 0.
*> \endverbatim
*>
*> \param[in] NCC
*> \verbatim
*> NCC is INTEGER
*> The number of columns of the matrix C. NCC >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the n diagonal elements of the bidiagonal matrix B.
*> On exit, if INFO=0, the singular values of B in decreasing
*> order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the N-1 offdiagonal elements of the bidiagonal
*> matrix B.
*> On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
*> will contain the diagonal and superdiagonal elements of a
*> bidiagonal matrix orthogonally equivalent to the one given
*> as input.
*> \endverbatim
*>
*> \param[in,out] VT
*> \verbatim
*> VT is COMPLEX*16 array, dimension (LDVT, NCVT)
*> On entry, an N-by-NCVT matrix VT.
*> On exit, VT is overwritten by P**H * VT.
*> Not referenced if NCVT = 0.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*> LDVT is INTEGER
*> The leading dimension of the array VT.
*> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*> \endverbatim
*>
*> \param[in,out] U
*> \verbatim
*> U is COMPLEX*16 array, dimension (LDU, N)
*> On entry, an NRU-by-N matrix U.
*> On exit, U is overwritten by U * Q.
*> Not referenced if NRU = 0.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> The leading dimension of the array U. LDU >= max(1,NRU).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, NCC)
*> On entry, an N-by-NCC matrix C.
*> On exit, C is overwritten by Q**H * C.
*> Not referenced if NCC = 0.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C.
*> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (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: the algorithm did not converge; D and E contain the
*> elements of a bidiagonal matrix which is orthogonally
*> similar to the input matrix B; if INFO = i, i
*> elements of E have not converged to zero.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
*> TOLMUL controls the convergence criterion of the QR loop.
*> If it is positive, TOLMUL*EPS is the desired relative
*> precision in the computed singular values.
*> If it is negative, abs(TOLMUL*EPS*sigma_max) is the
*> desired absolute accuracy in the computed singular
*> values (corresponds to relative accuracy
*> abs(TOLMUL*EPS) in the largest singular value.
*> abs(TOLMUL) should be between 1 and 1/EPS, and preferably
*> between 10 (for fast convergence) and .1/EPS
*> (for there to be some accuracy in the results).
*> Default is to lose at either one eighth or 2 of the
*> available decimal digits in each computed singular value
*> (whichever is smaller).
*>
*> MAXITR INTEGER, default = 6
*> MAXITR controls the maximum number of passes of the
*> algorithm through its inner loop. The algorithms stops
*> (and so fails to converge) if the number of passes
*> through the inner loop exceeds MAXITR*N**2.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, RWORK, 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 UPLO
INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION NEGONE
PARAMETER ( NEGONE = -1.0D0 )
DOUBLE PRECISION HNDRTH
PARAMETER ( HNDRTH = 0.01D0 )
DOUBLE PRECISION TEN
PARAMETER ( TEN = 10.0D0 )
DOUBLE PRECISION HNDRD
PARAMETER ( HNDRD = 100.0D0 )
DOUBLE PRECISION MEIGTH
PARAMETER ( MEIGTH = -0.125D0 )
INTEGER MAXITR
PARAMETER ( MAXITR = 6 )
* ..
* .. Local Scalars ..
LOGICAL LOWER, ROTATE
INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
$ NM12, NM13, OLDLL, OLDM
DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
$ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
$ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
$ SN, THRESH, TOL, TOLMUL, UNFL
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT,
$ ZDSCAL, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LOWER = LSAME( UPLO, 'L' )
IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NCVT.LT.0 ) THEN
INFO = -3
ELSE IF( NRU.LT.0 ) THEN
INFO = -4
ELSE IF( NCC.LT.0 ) THEN
INFO = -5
ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
$ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
INFO = -9
ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
INFO = -11
ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
$ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
INFO = -13
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZBDSQR', -INFO )
RETURN
END IF
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 )
$ GO TO 160
*
* ROTATE is true if any singular vectors desired, false otherwise
*
ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
*
* If no singular vectors desired, use qd algorithm
*
IF( .NOT.ROTATE ) THEN
CALL DLASQ1( N, D, E, RWORK, INFO )
*
* If INFO equals 2, dqds didn't finish, try to finish
*
IF( INFO .NE. 2 ) RETURN
INFO = 0
END IF
*
NM1 = N - 1
NM12 = NM1 + NM1
NM13 = NM12 + NM1
IDIR = 0
*
* Get machine constants
*
EPS = DLAMCH( 'Epsilon' )
UNFL = DLAMCH( 'Safe minimum' )
*
* If matrix lower bidiagonal, rotate to be upper bidiagonal
* by applying Givens rotations on the left
*
IF( LOWER ) THEN
DO 10 I = 1, N - 1
CALL DLARTG( D( I ), E( I ), CS, SN, R )
D( I ) = R
E( I ) = SN*D( I+1 )
D( I+1 ) = CS*D( I+1 )
RWORK( I ) = CS
RWORK( NM1+I ) = SN
10 CONTINUE
*
* Update singular vectors if desired
*
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
$ U, LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ),
$ C, LDC )
END IF
*
* Compute singular values to relative accuracy TOL
* (By setting TOL to be negative, algorithm will compute
* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*
TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
TOL = TOLMUL*EPS
*
* Compute approximate maximum, minimum singular values
*
SMAX = ZERO
DO 20 I = 1, N
SMAX = MAX( SMAX, ABS( D( I ) ) )
20 CONTINUE
DO 30 I = 1, N - 1
SMAX = MAX( SMAX, ABS( E( I ) ) )
30 CONTINUE
SMINL = ZERO
IF( TOL.GE.ZERO ) THEN
*
* Relative accuracy desired
*
SMINOA = ABS( D( 1 ) )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
MU = SMINOA
DO 40 I = 2, N
MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
SMINOA = MIN( SMINOA, MU )
IF( SMINOA.EQ.ZERO )
$ GO TO 50
40 CONTINUE
50 CONTINUE
SMINOA = SMINOA / SQRT( DBLE( N ) )
THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
ELSE
*
* Absolute accuracy desired
*
THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
END IF
*
* Prepare for main iteration loop for the singular values
* (MAXIT is the maximum number of passes through the inner
* loop permitted before nonconvergence signalled.)
*
MAXIT = MAXITR*N*N
ITER = 0
OLDLL = -1
OLDM = -1
*
* M points to last element of unconverged part of matrix
*
M = N
*
* Begin main iteration loop
*
60 CONTINUE
*
* Check for convergence or exceeding iteration count
*
IF( M.LE.1 )
$ GO TO 160
IF( ITER.GT.MAXIT )
$ GO TO 200
*
* Find diagonal block of matrix to work on
*
IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
$ D( M ) = ZERO
SMAX = ABS( D( M ) )
SMIN = SMAX
DO 70 LLL = 1, M - 1
LL = M - LLL
ABSS = ABS( D( LL ) )
ABSE = ABS( E( LL ) )
IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
$ D( LL ) = ZERO
IF( ABSE.LE.THRESH )
$ GO TO 80
SMIN = MIN( SMIN, ABSS )
SMAX = MAX( SMAX, ABSS, ABSE )
70 CONTINUE
LL = 0
GO TO 90
80 CONTINUE
E( LL ) = ZERO
*
* Matrix splits since E(LL) = 0
*
IF( LL.EQ.M-1 ) THEN
*
* Convergence of bottom singular value, return to top of loop
*
M = M - 1
GO TO 60
END IF
90 CONTINUE
LL = LL + 1
*
* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
*
IF( LL.EQ.M-1 ) THEN
*
* 2 by 2 block, handle separately
*
CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
$ COSR, SINL, COSL )
D( M-1 ) = SIGMX
E( M-1 ) = ZERO
D( M ) = SIGMN
*
* Compute singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
$ COSR, SINR )
IF( NRU.GT.0 )
$ CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
IF( NCC.GT.0 )
$ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
$ SINL )
M = M - 2
GO TO 60
END IF
*
* If working on new submatrix, choose shift direction
* (from larger end diagonal element towards smaller)
*
IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
*
* Chase bulge from top (big end) to bottom (small end)
*
IDIR = 1
ELSE
*
* Chase bulge from bottom (big end) to top (small end)
*
IDIR = 2
END IF
END IF
*
* Apply convergence tests
*
IF( IDIR.EQ.1 ) THEN
*
* Run convergence test in forward direction
* First apply standard test to bottom of matrix
*
IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
E( M-1 ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion forward
*
MU = ABS( D( LL ) )
SMINL = MU
DO 100 LLL = LL, M - 1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
100 CONTINUE
END IF
*
ELSE
*
* Run convergence test in backward direction
* First apply standard test to top of matrix
*
IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
$ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
E( LL ) = ZERO
GO TO 60
END IF
*
IF( TOL.GE.ZERO ) THEN
*
* If relative accuracy desired,
* apply convergence criterion backward
*
MU = ABS( D( M ) )
SMINL = MU
DO 110 LLL = M - 1, LL, -1
IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
E( LLL ) = ZERO
GO TO 60
END IF
MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
SMINL = MIN( SMINL, MU )
110 CONTINUE
END IF
END IF
OLDLL = LL
OLDM = M
*
* Compute shift. First, test if shifting would ruin relative
* accuracy, and if so set the shift to zero.
*
IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
$ MAX( EPS, HNDRTH*TOL ) ) THEN
*
* Use a zero shift to avoid loss of relative accuracy
*
SHIFT = ZERO
ELSE
*
* Compute the shift from 2-by-2 block at end of matrix
*
IF( IDIR.EQ.1 ) THEN
SLL = ABS( D( LL ) )
CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
ELSE
SLL = ABS( D( M ) )
CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
END IF
*
* Test if shift negligible, and if so set to zero
*
IF( SLL.GT.ZERO ) THEN
IF( ( SHIFT / SLL )**2.LT.EPS )
$ SHIFT = ZERO
END IF
END IF
*
* Increment iteration count
*
ITER = ITER + M - LL
*
* If SHIFT = 0, do simplified QR iteration
*
IF( SHIFT.EQ.ZERO ) THEN
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 120 I = LL, M - 1
CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
IF( I.GT.LL )
$ E( I-1 ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
RWORK( I-LL+1 ) = CS
RWORK( I-LL+1+NM1 ) = SN
RWORK( I-LL+1+NM12 ) = OLDCS
RWORK( I-LL+1+NM13 ) = OLDSN
120 CONTINUE
H = D( M )*CS
D( M ) = H*OLDCS
E( M-1 ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
$ RWORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
CS = ONE
OLDCS = ONE
DO 130 I = M, LL + 1, -1
CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
IF( I.LT.M )
$ E( I ) = OLDSN*R
CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
RWORK( I-LL ) = CS
RWORK( I-LL+NM1 ) = -SN
RWORK( I-LL+NM12 ) = OLDCS
RWORK( I-LL+NM13 ) = -OLDSN
130 CONTINUE
H = D( LL )*CS
D( LL ) = H*OLDCS
E( LL ) = H*OLDSN
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
$ RWORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
$ RWORK( N ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
END IF
ELSE
*
* Use nonzero shift
*
IF( IDIR.EQ.1 ) THEN
*
* Chase bulge from top to bottom
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( LL ) )-SHIFT )*
$ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
G = E( LL )
DO 140 I = LL, M - 1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.GT.LL )
$ E( I-1 ) = R
F = COSR*D( I ) + SINR*E( I )
E( I ) = COSR*E( I ) - SINR*D( I )
G = SINR*D( I+1 )
D( I+1 ) = COSR*D( I+1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I ) + SINL*D( I+1 )
D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
IF( I.LT.M-1 ) THEN
G = SINL*E( I+1 )
E( I+1 ) = COSL*E( I+1 )
END IF
RWORK( I-LL+1 ) = COSR
RWORK( I-LL+1+NM1 ) = SINR
RWORK( I-LL+1+NM12 ) = COSL
RWORK( I-LL+1+NM13 ) = SINL
140 CONTINUE
E( M-1 ) = F
*
* Update singular vectors
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
$ RWORK( N ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), C( LL, 1 ), LDC )
*
* Test convergence
*
IF( ABS( E( M-1 ) ).LE.THRESH )
$ E( M-1 ) = ZERO
*
ELSE
*
* Chase bulge from bottom to top
* Save cosines and sines for later singular vector updates
*
F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
$ D( M ) )
G = E( M-1 )
DO 150 I = M, LL + 1, -1
CALL DLARTG( F, G, COSR, SINR, R )
IF( I.LT.M )
$ E( I ) = R
F = COSR*D( I ) + SINR*E( I-1 )
E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
G = SINR*D( I-1 )
D( I-1 ) = COSR*D( I-1 )
CALL DLARTG( F, G, COSL, SINL, R )
D( I ) = R
F = COSL*E( I-1 ) + SINL*D( I-1 )
D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
IF( I.GT.LL+1 ) THEN
G = SINL*E( I-2 )
E( I-2 ) = COSL*E( I-2 )
END IF
RWORK( I-LL ) = COSR
RWORK( I-LL+NM1 ) = -SINR
RWORK( I-LL+NM12 ) = COSL
RWORK( I-LL+NM13 ) = -SINL
150 CONTINUE
E( LL ) = F
*
* Test convergence
*
IF( ABS( E( LL ) ).LE.THRESH )
$ E( LL ) = ZERO
*
* Update singular vectors if desired
*
IF( NCVT.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
$ RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
IF( NRU.GT.0 )
$ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
$ RWORK( N ), U( 1, LL ), LDU )
IF( NCC.GT.0 )
$ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
$ RWORK( N ), C( LL, 1 ), LDC )
END IF
END IF
*
* QR iteration finished, go back and check convergence
*
GO TO 60
*
* All singular values converged, so make them positive
*
160 CONTINUE
DO 170 I = 1, N
IF( D( I ).LT.ZERO ) THEN
D( I ) = -D( I )
*
* Change sign of singular vectors, if desired
*
IF( NCVT.GT.0 )
$ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
END IF
170 CONTINUE
*
* Sort the singular values into decreasing order (insertion sort on
* singular values, but only one transposition per singular vector)
*
DO 190 I = 1, N - 1
*
* Scan for smallest D(I)
*
ISUB = 1
SMIN = D( 1 )
DO 180 J = 2, N + 1 - I
IF( D( J ).LE.SMIN ) THEN
ISUB = J
SMIN = D( J )
END IF
180 CONTINUE
IF( ISUB.NE.N+1-I ) THEN
*
* Swap singular values and vectors
*
D( ISUB ) = D( N+1-I )
D( N+1-I ) = SMIN
IF( NCVT.GT.0 )
$ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
$ LDVT )
IF( NRU.GT.0 )
$ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
IF( NCC.GT.0 )
$ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
END IF
190 CONTINUE
GO TO 220
*
* Maximum number of iterations exceeded, failure to converge
*
200 CONTINUE
INFO = 0
DO 210 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
210 CONTINUE
220 CONTINUE
RETURN
*
* End of ZBDSQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmbr.f 0000644 0000000 0000000 00000000132 14061636515 015341 x ustar 00 30 mtime=1623670093.217104068
30 atime=1623670093.217104068
30 ctime=1623670093.217104068
elk-7.2.42/src/LAPACK/zunmbr.f 0000644 0025044 0025044 00000025553 14061636515 017410 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMBR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMBR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
* LDC, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, VECT
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
*> with
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
*> with
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': P * C C * P
*> TRANS = 'C': P**H * C C * P**H
*>
*> Here Q and P**H are the unitary matrices determined by ZGEBRD when
*> reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
*> and P**H are defined as products of elementary reflectors H(i) and
*> G(i) respectively.
*>
*> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
*> order of the unitary matrix Q or P**H that is applied.
*>
*> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
*> if nq >= k, Q = H(1) H(2) . . . H(k);
*> if nq < k, Q = H(1) H(2) . . . H(nq-1).
*>
*> If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
*> if k < nq, P = G(1) G(2) . . . G(k);
*> if k >= nq, P = G(1) G(2) . . . G(nq-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] VECT
*> \verbatim
*> VECT is CHARACTER*1
*> = 'Q': apply Q or Q**H;
*> = 'P': apply P or P**H.
*> \endverbatim
*>
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q, Q**H, P or P**H from the Left;
*> = 'R': apply Q, Q**H, P or P**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q or P;
*> = 'C': Conjugate transpose, apply Q**H or P**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> If VECT = 'Q', the number of columns in the original
*> matrix reduced by ZGEBRD.
*> If VECT = 'P', the number of rows in the original
*> matrix reduced by ZGEBRD.
*> K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,min(nq,K)) if VECT = 'Q'
*> (LDA,nq) if VECT = 'P'
*> The vectors which define the elementary reflectors H(i) and
*> G(i), whose products determine the matrices Q and P, as
*> returned by ZGEBRD.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If VECT = 'Q', LDA >= max(1,nq);
*> if VECT = 'P', LDA >= max(1,min(nq,K)).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(nq,K))
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i) or G(i) which determines Q or P, as returned
*> by ZGEBRD in the array argument TAUQ or TAUP.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
*> or P*C or P**H*C or C*P or C*P**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M);
*> if N = 0 or M = 0, LWORK >= 1.
*> For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
*> and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
*> optimal blocksize. (NB = 0 if M = 0 or N = 0.)
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, 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 SIDE, TRANS, VECT
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMLQ, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
APPLYQ = LSAME( VECT, 'Q' )
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q or P and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
NW = 0
END IF
IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
INFO = -1
ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( K.LT.0 ) THEN
INFO = -6
ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
$ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
$ THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( NW.GT.0 ) THEN
IF( APPLYQ ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW*NB )
ELSE
LWKOPT = 1
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMBR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( APPLYQ ) THEN
*
* Apply Q
*
IF( NQ.GE.K ) THEN
*
* Q was determined by a call to ZGEBRD with nq >= k
*
CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* Q was determined by a call to ZGEBRD with nq < k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
ELSE
*
* Apply P
*
IF( NOTRAN ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
IF( NQ.GT.K ) THEN
*
* P was determined by a call to ZGEBRD with nq > k
*
CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, IINFO )
ELSE IF( NQ.GT.1 ) THEN
*
* P was determined by a call to ZGEBRD with nq <= k
*
IF( LEFT ) THEN
MI = M - 1
NI = N
I1 = 2
I2 = 1
ELSE
MI = M
NI = N - 1
I1 = 1
I2 = 2
END IF
CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
$ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMBR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgetrs.f 0000644 0000000 0000000 00000000132 14061636515 015342 x ustar 00 30 mtime=1623670093.219104066
30 atime=1623670093.219104066
30 ctime=1623670093.219104066
elk-7.2.42/src/LAPACK/zgetrs.f 0000644 0025044 0025044 00000013643 14061636515 017406 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGETRS
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGETRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRS solves a system of linear equations
*> A * X = B, A**T * X = B, or A**H * X = B
*> with a general N-by-N matrix A using the LU factorization computed
*> by ZGETRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the form of the system of equations:
*> = 'N': A * X = B (No transpose)
*> = 'T': A**T * X = B (Transpose)
*> = 'C': A**H * X = B (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand sides, i.e., the number of columns
*> of the matrix B. NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by ZGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N)
*> The pivot indices from ZGETRF; for 1<=i<=N, row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,NRHS)
*> On entry, the right hand side matrix B.
*> On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, 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 TRANS
INTEGER INFO, LDA, LDB, N, NRHS
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLASWP, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( NRHS.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. NRHS.EQ.0 )
$ RETURN
*
IF( NOTRAN ) THEN
*
* Solve A * X = B.
*
* Apply row interchanges to the right hand sides.
*
CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
* Solve L*X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
$ ONE, A, LDA, B, LDB )
*
* Solve U*X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
$ NRHS, ONE, A, LDA, B, LDB )
ELSE
*
* Solve A**T * X = B or A**H * X = B.
*
* Solve U**T *X = B or U**H *X = B, overwriting B with X.
*
CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
$ A, LDA, B, LDB )
*
* Solve L**T *X = B, or L**H *X = B overwriting B with X.
*
CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
$ LDA, B, LDB )
*
* Apply row interchanges to the solution vectors.
*
CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
END IF
*
RETURN
*
* End of ZGETRS
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgetrf2.f 0000644 0000000 0000000 00000000132 14061636515 015407 x ustar 00 30 mtime=1623670093.221104064
30 atime=1623670093.221104064
30 ctime=1623670093.221104064
elk-7.2.42/src/LAPACK/zgetrf2.f 0000644 0025044 0025044 00000015711 14061636515 017451 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGETRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGETRF2 computes an LU factorization of a general M-by-N matrix A
*> using partial pivoting with row interchanges.
*>
*> The factorization has the form
*> A = P * L * U
*> where P is a permutation matrix, L is lower triangular with unit
*> diagonal elements (lower trapezoidal if m > n), and U is upper
*> triangular (upper trapezoidal if m < n).
*>
*> This is the recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = min(m,n)/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> [ A11 ]
*> The subroutine calls itself to factor [ --- ],
*> [ A12 ]
*> [ A12 ]
*> do the swaps on [ --- ], solve A12, update A22,
*> [ A22 ]
*>
*> then calls itself to factor A22 and do the swaps on A21.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the M-by-N matrix to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (min(M,N))
*> The pivot indices; for 1 <= i <= min(M,N), row i of the
*> matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*> has been completed, but the factor U is exactly
*> singular, and division by zero will occur if it is used
*> to solve a system of equations.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16GEcomputational
*
* =====================================================================
RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, 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 INFO, LDA, M, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
DOUBLE PRECISION SFMIN
COMPLEX*16 TEMP
INTEGER I, IINFO, N1, N2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER IZAMAX
EXTERNAL DLAMCH, IZAMAX
* ..
* .. External Subroutines ..
EXTERNAL ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGETRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
IF ( M.EQ.1 ) THEN
*
* Use unblocked code for one row case
* Just need to handle IPIV and INFO
*
IPIV( 1 ) = 1
IF ( A(1,1).EQ.ZERO )
$ INFO = 1
*
ELSE IF( N.EQ.1 ) THEN
*
* Use unblocked code for one column case
*
*
* Compute machine safe minimum
*
SFMIN = DLAMCH('S')
*
* Find pivot and test for singularity
*
I = IZAMAX( M, A( 1, 1 ), 1 )
IPIV( 1 ) = I
IF( A( I, 1 ).NE.ZERO ) THEN
*
* Apply the interchange
*
IF( I.NE.1 ) THEN
TEMP = A( 1, 1 )
A( 1, 1 ) = A( I, 1 )
A( I, 1 ) = TEMP
END IF
*
* Compute elements 2:M of the column
*
IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN
CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 )
ELSE
DO 10 I = 1, M-1
A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 )
10 CONTINUE
END IF
*
ELSE
INFO = 1
END IF
ELSE
*
* Use recursive code
*
N1 = MIN( M, N ) / 2
N2 = N-N1
*
* [ A11 ]
* Factor [ --- ]
* [ A21 ]
*
CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO )
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO
*
* [ A12 ]
* Apply interchanges to [ --- ]
* [ A22 ]
*
CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 )
*
* Solve A12
*
CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA,
$ A( 1, N1+1 ), LDA )
*
* Update A22
*
CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA )
*
* Factor A22
*
CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ),
$ IINFO )
*
* Adjust INFO and the pivot indices
*
IF ( INFO.EQ.0 .AND. IINFO.GT.0 )
$ INFO = IINFO + N1
DO 20 I = N1+1, MIN( M, N )
IPIV( I ) = IPIV( I ) + N1
20 CONTINUE
*
* Apply interchanges to A21
*
CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 )
*
END IF
RETURN
*
* End of ZGETRF2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaswp.f 0000644 0000000 0000000 00000000132 14061636515 015344 x ustar 00 30 mtime=1623670093.223104062
30 atime=1623670093.222104063
30 ctime=1623670093.223104062
elk-7.2.42/src/LAPACK/zlaswp.f 0000644 0025044 0025044 00000012005 14061636515 017377 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASWP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASWP performs a series of row interchanges on the matrix A.
*> One row interchange is initiated for each of rows K1 through K2 of A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the matrix of column dimension N to which the row
*> interchanges will be applied.
*> On exit, the permuted matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] K1
*> \verbatim
*> K1 is INTEGER
*> The first element of IPIV for which a row interchange will
*> be done.
*> \endverbatim
*>
*> \param[in] K2
*> \verbatim
*> K2 is INTEGER
*> (K2-K1+1) is the number of elements of IPIV for which a row
*> interchange will be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
*> The vector of pivot indices. Only the elements in positions
*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
*> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
*> interchanged.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of IPIV. If INCX
*> is negative, the pivots are applied in reverse order.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Modified by
*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.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 INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
COMPLEX*16 TEMP
* ..
* .. Executable Statements ..
*
* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
* K1 through K2.
*
IF( INCX.GT.0 ) THEN
IX0 = K1
I1 = K1
I2 = K2
INC = 1
ELSE IF( INCX.LT.0 ) THEN
IX0 = K1 + ( K1-K2 )*INCX
I1 = K2
I2 = K1
INC = -1
ELSE
RETURN
END IF
*
N32 = ( N / 32 )*32
IF( N32.NE.0 ) THEN
DO 30 J = 1, N32, 32
IX = IX0
DO 20 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 10 K = J, J + 31
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
10 CONTINUE
END IF
IX = IX + INCX
20 CONTINUE
30 CONTINUE
END IF
IF( N32.NE.N ) THEN
N32 = N32 + 1
IX = IX0
DO 50 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 40 K = N32, N
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
40 CONTINUE
END IF
IX = IX + INCX
50 CONTINUE
END IF
*
RETURN
*
* End of ZLASWP
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ztrtri.f 0000644 0000000 0000000 00000000132 14061636515 015362 x ustar 00 30 mtime=1623670093.225104061
30 atime=1623670093.224104061
30 ctime=1623670093.225104061
elk-7.2.42/src/LAPACK/ztrtri.f 0000644 0025044 0025044 00000015450 14061636515 017424 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRTRI
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTRI + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRTRI computes the inverse of a complex upper or lower triangular
*> matrix A.
*>
*> This is the Level 3 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': A is upper triangular;
*> = 'L': A is lower triangular.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> = 'N': A is non-unit triangular;
*> = 'U': A is unit triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the triangular matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of the array A contains
*> the upper triangular matrix, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of the array A contains
*> the lower triangular matrix, and the strictly upper
*> triangular part of A is not referenced. If DIAG = 'U', the
*> diagonal elements of A are also not referenced and are
*> assumed to be 1.
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, A(i,i) is exactly zero. The triangular
*> matrix is singular and its inverse can not be computed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J, JB, NB, NN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRTRI', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Check for singularity if non-unit.
*
IF( NOUNIT ) THEN
DO 10 INFO = 1, N
IF( A( INFO, INFO ).EQ.ZERO )
$ RETURN
10 CONTINUE
INFO = 0
END IF
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
ELSE
*
* Use blocked code
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix
*
DO 20 J = 1, N, NB
JB = MIN( NB, N-J+1 )
*
* Compute rows 1:j-1 of current block column
*
CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
$ JB, ONE, A, LDA, A( 1, J ), LDA )
CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
$ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
*
* Compute inverse of current diagonal block
*
CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
20 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix
*
NN = ( ( N-1 ) / NB )*NB + 1
DO 30 J = NN, 1, -NB
JB = MIN( NB, N-J+1 )
IF( J+JB.LE.N ) THEN
*
* Compute rows j+jb:n of current block column
*
CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
$ A( J+JB, J ), LDA )
CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG,
$ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
$ A( J+JB, J ), LDA )
END IF
*
* Compute inverse of current diagonal block
*
CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
30 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZTRTRI
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlanhe.f 0000644 0000000 0000000 00000000127 14061636515 015311 x ustar 00 29 mtime=1623670093.22610406
29 atime=1623670093.22610406
29 ctime=1623670093.22610406
elk-7.2.42/src/LAPACK/zlanhe.f 0000644 0025044 0025044 00000021074 14061636515 017346 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHE returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> complex hermitian matrix A.
*> \endverbatim
*>
*> \return ZLANHE
*> \verbatim
*>
*> ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANHE as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> hermitian matrix A is to be referenced.
*> = 'U': Upper triangular part of A is referenced
*> = 'L': Lower triangular part of A is referenced
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHE is
*> set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The hermitian matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of A contains the upper triangular part
*> of the matrix A, and the strictly lower triangular part of A
*> is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of A contains the lower triangular part of
*> the matrix A, and the strictly upper triangular part of A is
*> not referenced. Note that the imaginary parts of the diagonal
*> elements need not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(N,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
*
* -- 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
*
IMPLICIT NONE
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION ABSA, SUM, VALUE
* ..
* .. Local Arrays ..
DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ, DCOMBSSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, J - 1
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
DO 40 J = 1, N
SUM = ABS( DBLE( A( J, J ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = J + 1, N
SUM = ABS( A( I, J ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
DO 90 I = J + 1, N
ABSA = ABS( A( I, J ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
* SSQ(1) is scale
* SSQ(2) is sum-of-squares
* For better accuracy, sum each column separately.
*
SSQ( 1 ) = ZERO
SSQ( 2 ) = ONE
*
* Sum off-diagonals
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL ZLASSQ( J-1, A( 1, J ), 1,
$ COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL ZLASSQ( N-J, A( J+1, J ), 1,
$ COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
120 CONTINUE
END IF
SSQ( 2 ) = 2*SSQ( 2 )
*
* Sum diagonal
*
DO 130 I = 1, N
IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( A( I, I ) ) )
IF( SSQ( 1 ).LT.ABSA ) THEN
SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2
SSQ( 1 ) = ABSA
ELSE
SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2
END IF
END IF
130 CONTINUE
VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
END IF
*
ZLANHE = VALUE
RETURN
*
* End of ZLANHE
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhetrd.f 0000644 0000000 0000000 00000000132 14061636515 015324 x ustar 00 30 mtime=1623670093.228104058
30 atime=1623670093.228104058
30 ctime=1623670093.228104058
elk-7.2.42/src/LAPACK/zhetrd.f 0000644 0025044 0025044 00000026461 14061636515 017372 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHETRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETRD reduces a complex Hermitian matrix A to real symmetric
*> tridiagonal form T by a unitary similarity transformation:
*> Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
*> of A are overwritten by the corresponding elements of the
*> tridiagonal matrix T, and the elements above the first
*> superdiagonal, with the array TAU, represent the unitary
*> matrix Q as a product of elementary reflectors; if UPLO
*> = 'L', the diagonal and first subdiagonal of A are over-
*> written by the corresponding elements of the tridiagonal
*> matrix T, and the elements below the first subdiagonal, with
*> the array TAU, represent the unitary matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= 1.
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n-1) . . . H(2) H(1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
*> A(1:i-1,i+1), and tau in TAU(i).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(n-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
*> and tau in TAU(i).
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( d e v2 v3 v4 ) ( d )
*> ( d e v3 v4 ) ( e d )
*> ( d e v4 ) ( v1 e d )
*> ( d e ) ( v1 v2 e d )
*> ( d ) ( v1 v2 v3 e d )
*>
*> where d and e denote diagonal and off-diagonal elements of T, and vi
*> denotes an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.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 INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
$ NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
INFO = -9
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Determine the block size.
*
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
LWKOPT = N*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETRD', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NX = N
IWS = 1
IF( NB.GT.1 .AND. NB.LT.N ) THEN
*
* Determine when to cross over from blocked to unblocked code
* (last block is always handled by unblocked code).
*
NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
IF( NX.LT.N ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: determine the
* minimum value of NB, and reduce NB or force use of
* unblocked code by setting NX = N.
*
NB = MAX( LWORK / LDWORK, 1 )
NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
IF( NB.LT.NBMIN )
$ NX = N
END IF
ELSE
NX = N
END IF
ELSE
NB = 1
END IF
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* Columns 1:kk are handled by the unblocked method.
*
KK = N - ( ( N-NX+NB-1 ) / NB )*NB
DO 20 I = N - NB + 1, KK + 1, -NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
$ LDWORK )
*
* Update the unreduced submatrix A(1:i-1,1:i-1), using an
* update of the form: A := A - V*W**H - W*V**H
*
CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
$ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
*
* Copy superdiagonal elements back into A, and diagonal
* elements into D
*
DO 10 J = I, I + NB - 1
A( J-1, J ) = E( J-1 )
D( J ) = A( J, J )
10 CONTINUE
20 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
ELSE
*
* Reduce the lower triangle of A
*
DO 40 I = 1, N - NX, NB
*
* Reduce columns i:i+nb-1 to tridiagonal form and form the
* matrix W which is needed to update the unreduced part of
* the matrix
*
CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
$ TAU( I ), WORK, LDWORK )
*
* Update the unreduced submatrix A(i+nb:n,i+nb:n), using
* an update of the form: A := A - V*W**H - W*V**H
*
CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
$ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
$ A( I+NB, I+NB ), LDA )
*
* Copy subdiagonal elements back into A, and diagonal
* elements into D
*
DO 30 J = I, I + NB - 1
A( J+1, J ) = E( J )
D( J ) = A( J, J )
30 CONTINUE
40 CONTINUE
*
* Use unblocked code to reduce the last or only block
*
CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
$ TAU( I ), IINFO )
END IF
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZHETRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zstedc.f 0000644 0000000 0000000 00000000132 14061636515 015320 x ustar 00 30 mtime=1623670093.231104055
30 atime=1623670093.230104056
30 ctime=1623670093.231104055
elk-7.2.42/src/LAPACK/zstedc.f 0000644 0025044 0025044 00000037324 14061636515 017366 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZSTEDC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEDC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
* LRWORK, IWORK, LIWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
*> symmetric tridiagonal matrix using the divide and conquer method.
*> The eigenvectors of a full or band complex Hermitian matrix can also
*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
*> matrix to tridiagonal form.
*>
*> 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 DLAED3 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 Hermitian matrix
*> also. On entry, Z contains the unitary matrix used
*> to reduce the original matrix to tridiagonal form.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the subdiagonal elements of the tridiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> On entry, if COMPZ = 'V', then Z contains the unitary
*> matrix used in the reduction to tridiagonal form.
*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
*> orthonormal eigenvectors of the original Hermitian matrix,
*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors
*> of the symmetric tridiagonal matrix.
*> If COMPZ = 'N', then Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1.
*> If eigenvectors are desired, then LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
*> If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
*> Note that for COMPZ = 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LWORK need
*> only be 1.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal sizes of the WORK, RWORK and
*> IWORK arrays, returns these values as the first entries of
*> the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
*> \endverbatim
*>
*> \param[in] LRWORK
*> \verbatim
*> LRWORK is INTEGER
*> The dimension of the array RWORK.
*> If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
*> If COMPZ = 'V' and N > 1, LRWORK must be at least
*> 1 + 3*N + 2*N*lg N + 4*N**2 ,
*> where lg( N ) = smallest integer k such
*> that 2**k >= N.
*> If COMPZ = 'I' and N > 1, LRWORK must be at least
*> 1 + 4*N + 2*N**2 .
*> Note that for COMPZ = 'I' or 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LRWORK
*> need only be max(1,2*(N-1)).
*>
*> If LRWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MAX(1,LIWORK))
*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*> LIWORK is INTEGER
*> The dimension of the array IWORK.
*> If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
*> If COMPZ = 'V' or N > 1, LIWORK must be at least
*> 6 + 6*N + 5*N*lg N.
*> If COMPZ = 'I' or N > 1, LIWORK must be at least
*> 3 + 5*N .
*> Note that for COMPZ = 'I' or 'V', then if N is less than or
*> equal to the minimum divide size, usually 25, then LIWORK
*> need only be 1.
*>
*> If LIWORK = -1, then a workspace query is assumed; the
*> routine only calculates the optimal sizes of the WORK, RWORK
*> and IWORK arrays, returns these values as the first entries
*> of the WORK, RWORK and IWORK arrays, and no error message
*> related to LWORK or LRWORK or LIWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: The algorithm failed to compute an eigenvalue while
*> working on the submatrix lying in rows and columns
*> INFO/(N+1) through mod(INFO,N+1).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16OTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
$ LRWORK, IWORK, LIWORK, INFO )
*
* -- LAPACK computational routine (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 ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
$ LRWMIN, LWMIN, M, SMLSIZ, START
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA,
$ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR.
$ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 )
IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 1
ELSE IF( N.LE.SMLSIZ ) THEN
LWMIN = 1
LIWMIN = 1
LRWMIN = 2*( N - 1 )
ELSE IF( ICOMPZ.EQ.1 ) THEN
LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
LWMIN = N*N
LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2
LIWMIN = 6 + 6*N + 5*N*LGN
ELSE IF( ICOMPZ.EQ.2 ) THEN
LWMIN = 1
LRWMIN = 1 + 4*N + 2*N**2
LIWMIN = 3 + 5*N
END IF
WORK( 1 ) = LWMIN
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
INFO = -8
ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
INFO = -10
ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEDC', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 70
END IF
*
* If N is smaller than the minimum divide size (SMLSIZ+1), then
* solve the problem with another solver.
*
IF( N.LE.SMLSIZ ) THEN
*
CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
*
ELSE
*
* If COMPZ = 'I', we simply call DSTEDC instead.
*
IF( ICOMPZ.EQ.2 ) THEN
CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
LL = N*N + 1
CALL DSTEDC( 'I', N, D, E, RWORK, N,
$ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
DO 20 J = 1, N
DO 10 I = 1, N
Z( I, J ) = RWORK( ( J-1 )*N+I )
10 CONTINUE
20 CONTINUE
GO TO 70
END IF
*
* From now on, only option left to be handled is COMPZ = 'V',
* i.e. ICOMPZ = 1.
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 70
*
EPS = DLAMCH( 'Epsilon' )
*
START = 1
*
* while ( START <= N )
*
30 CONTINUE
IF( START.LE.N ) THEN
*
* Let FINISH be the position of the next subdiagonal entry
* such that E( FINISH ) <= TINY or FINISH = N if no such
* subdiagonal exists. The matrix identified by the elements
* between START and FINISH constitutes an independent
* sub-problem.
*
FINISH = START
40 CONTINUE
IF( FINISH.LT.N ) THEN
TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
$ SQRT( ABS( D( FINISH+1 ) ) )
IF( ABS( E( FINISH ) ).GT.TINY ) THEN
FINISH = FINISH + 1
GO TO 40
END IF
END IF
*
* (Sub) Problem determined. Compute its size and solve it.
*
M = FINISH - START + 1
IF( M.GT.SMLSIZ ) THEN
*
* Scale.
*
ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ),
$ LDZ, WORK, N, RWORK, IWORK, INFO )
IF( INFO.GT.0 ) THEN
INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
$ MOD( INFO, ( M+1 ) ) + START - 1
GO TO 70
END IF
*
* Scale back.
*
CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
$ INFO )
*
ELSE
CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
$ RWORK( M*M+1 ), INFO )
CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N,
$ RWORK( M*M+1 ) )
CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
IF( INFO.GT.0 ) THEN
INFO = START*( N+1 ) + FINISH
GO TO 70
END IF
END IF
*
START = FINISH + 1
GO TO 30
END IF
*
* endwhile
*
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 60 II = 2, N
I = II - 1
K = I
P = D( I )
DO 50 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
50 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
60 CONTINUE
END IF
*
70 CONTINUE
WORK( 1 ) = LWMIN
RWORK( 1 ) = LRWMIN
IWORK( 1 ) = LIWMIN
*
RETURN
*
* End of ZSTEDC
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmtr.f 0000644 0000000 0000000 00000000132 14061636515 015363 x ustar 00 30 mtime=1623670093.233104053
30 atime=1623670093.232104054
30 ctime=1623670093.233104053
elk-7.2.42/src/LAPACK/zunmtr.f 0000644 0025044 0025044 00000021123 14061636515 017417 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, UPLO
* INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMTR overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix of order nq, with nq = m if
*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
*> nq-1 elementary reflectors, as returned by ZHETRD:
*>
*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A contains elementary reflectors
*> from ZHETRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from ZHETRD.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Conjugate transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L'
*> (LDA,N) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by ZHETRD.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZHETRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
*> LWORK >=M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMQL, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
UPPER = LSAME( UPLO, 'U' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = 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.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = M - 1
NI = N
ELSE
MI = M
NI = N - 1
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHETRD with UPLO = 'U'
*
CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to ZHETRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zungtr.f 0000644 0000000 0000000 00000000132 14061636515 015355 x ustar 00 30 mtime=1623670093.235104051
30 atime=1623670093.234104052
30 ctime=1623670093.235104051
elk-7.2.42/src/LAPACK/zungtr.f 0000644 0025044 0025044 00000015641 14061636515 017421 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGTR generates a complex unitary matrix Q which is defined as the
*> product of n-1 elementary reflectors of order N, as returned by
*> ZHETRD:
*>
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A contains elementary reflectors
*> from ZHETRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from ZHETRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the vectors which define the elementary reflectors,
*> as returned by ZHETRD.
*> On exit, the N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= N.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZHETRD.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N-1.
*> For optimum performance LWORK >= (N-1)*NB, where NB is
*> the optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, 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 UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY, UPPER
INTEGER I, IINFO, J, LWKOPT, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNGQL, ZUNGQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
INFO = -7
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 )
ELSE
NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 )
END IF
LWKOPT = MAX( 1, N-1 )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGTR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHETRD with UPLO = 'U'
*
* Shift the vectors which define the elementary reflectors one
* column to the left, and set the last row and column of Q to
* those of the unit matrix
*
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
A( I, J ) = A( I, J+1 )
10 CONTINUE
A( N, J ) = ZERO
20 CONTINUE
DO 30 I = 1, N - 1
A( I, N ) = ZERO
30 CONTINUE
A( N, N ) = ONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHETRD with UPLO = 'L'.
*
* Shift the vectors which define the elementary reflectors one
* column to the right, and set the first row and column of Q to
* those of the unit matrix
*
DO 50 J = N, 2, -1
A( 1, J ) = ZERO
DO 40 I = J + 1, N
A( I, J ) = A( I, J-1 )
40 CONTINUE
50 CONTINUE
A( 1, 1 ) = ONE
DO 60 I = 2, N
A( I, 1 ) = ZERO
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
$ LWORK, IINFO )
END IF
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNGTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zsteqr.f 0000644 0000000 0000000 00000000131 14061636515 015353 x ustar 00 30 mtime=1623670093.237104049
29 atime=1623670093.23610405
30 ctime=1623670093.237104049
elk-7.2.42/src/LAPACK/zsteqr.f 0000644 0025044 0025044 00000036610 14061636515 017417 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZSTEQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPZ
* INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), WORK( * )
* COMPLEX*16 Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
*> symmetric tridiagonal matrix using the implicit QL or QR method.
*> The eigenvectors of a full or band complex Hermitian matrix can also
*> be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
*> matrix to tridiagonal form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMPZ
*> \verbatim
*> COMPZ is CHARACTER*1
*> = 'N': Compute eigenvalues only.
*> = 'V': Compute eigenvalues and eigenvectors of the original
*> Hermitian matrix. On entry, Z must contain the
*> unitary matrix used to reduce the original matrix
*> to tridiagonal form.
*> = 'I': Compute eigenvalues and eigenvectors of the
*> tridiagonal matrix. Z is initialized to the identity
*> matrix.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the (n-1) subdiagonal elements of the tridiagonal
*> matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, N)
*> On entry, if COMPZ = 'V', then Z contains the unitary
*> matrix used in the reduction to tridiagonal form.
*> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
*> orthonormal eigenvectors of the original Hermitian matrix,
*> and if COMPZ = 'I', Z contains the orthonormal eigenvectors
*> of the symmetric tridiagonal matrix.
*> If COMPZ = 'N', then Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> eigenvectors are desired, then LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
*> If COMPZ = 'N', then WORK is not referenced.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: the algorithm has failed to find all the eigenvalues in
*> a total of 30*N iterations; if INFO = i, then i
*> elements of E have not converged to zero; on exit, D
*> and E contain the elements of a symmetric tridiagonal
*> matrix which is unitarily similar to the original
*> matrix.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZSTEQR( 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 ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
$ ZLASET, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.EQ.NMAXIT ) THEN
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
RETURN
END IF
GO TO 10
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
RETURN
*
* End of ZSTEQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zpotrf.f 0000644 0000000 0000000 00000000132 14061636515 015350 x ustar 00 30 mtime=1623670093.239104048
30 atime=1623670093.238104048
30 ctime=1623670093.239104048
elk-7.2.42/src/LAPACK/zpotrf.f 0000644 0025044 0025044 00000016325 14061636515 017414 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZPOTRF
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPOTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A.
*>
*> The factorization has the form
*> A = U**H * U, if UPLO = 'U', or
*> A = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the block version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**H *U or A = L*L**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16POcomputational
*
* =====================================================================
SUBROUTINE ZPOTRF( UPLO, N, A, LDA, 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 UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
COMPLEX*16 CONE
PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER J, JB, NB
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTRF2, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOTRF', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code.
*
CALL ZPOTRF2( UPLO, N, A, LDA, INFO )
ELSE
*
* Use blocked code.
*
IF( UPPER ) THEN
*
* Compute the Cholesky factorization A = U**H *U.
*
DO 10 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1,
$ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
CALL ZPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block row.
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB,
$ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA,
$ A( 1, J+JB ), LDA, CONE, A( J, J+JB ),
$ LDA )
CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
$ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
$ LDA, A( J, J+JB ), LDA )
END IF
10 CONTINUE
*
ELSE
*
* Compute the Cholesky factorization A = L*L**H.
*
DO 20 J = 1, N, NB
*
* Update and factorize the current diagonal block and test
* for non-positive-definiteness.
*
JB = MIN( NB, N-J+1 )
CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
$ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
CALL ZPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO )
IF( INFO.NE.0 )
$ GO TO 30
IF( J+JB.LE.N ) THEN
*
* Compute the current block column.
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ),
$ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ),
$ LDA )
CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
$ LDA, A( J+JB, J ), LDA )
END IF
20 CONTINUE
END IF
END IF
GO TO 40
*
30 CONTINUE
INFO = INFO + J - 1
*
40 CONTINUE
RETURN
*
* End of ZPOTRF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhegst.f 0000644 0000000 0000000 00000000132 14061636515 015330 x ustar 00 30 mtime=1623670093.241104046
30 atime=1623670093.240104047
30 ctime=1623670093.241104046
elk-7.2.42/src/LAPACK/zhegst.f 0000644 0025044 0025044 00000026323 14061636515 017373 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEGST
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEGST + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEGST reduces a complex Hermitian-definite generalized
*> eigenproblem to standard form.
*>
*> If ITYPE = 1, the problem is A*x = lambda*B*x,
*> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
*>
*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
*> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
*>
*> B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
*> = 2 or 3: compute U*A*U**H or L**H*A*L.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored and B is factored as
*> U**H*U;
*> = 'L': Lower triangle of A is stored and B is factored as
*> L*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the transformed matrix, stored in the
*> same format as A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> The triangular factor from the Cholesky factorization of B,
*> as returned by ZPOTRF.
*> B is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEcomputational
*
* =====================================================================
SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, 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 UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
COMPLEX*16 CONE, HALF
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K, KB, NB
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZHEGS2, ZHEMM, ZHER2K, ZTRMM, ZTRSM
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEGST', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine the block size for this environment.
*
NB = ILAENV( 1, 'ZHEGST', UPLO, N, -1, -1, -1 )
*
IF( NB.LE.1 .OR. NB.GE.N ) THEN
*
* Use unblocked code
*
CALL ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
ELSE
*
* Use blocked code
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U**H)*A*inv(U)
*
DO 10 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(k:n,k:n)
*
CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL ZTRSM( 'Left', UPLO, 'Conjugate transpose',
$ 'Non-unit', KB, N-K-KB+1, CONE,
$ B( K, K ), LDB, A( K, K+KB ), LDA )
CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB,
$ CONE, A( K, K+KB ), LDA )
CALL ZHER2K( UPLO, 'Conjugate transpose', N-K-KB+1,
$ KB, -CONE, A( K, K+KB ), LDA,
$ B( K, K+KB ), LDB, ONE,
$ A( K+KB, K+KB ), LDA )
CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
$ A( K, K ), LDA, B( K, K+KB ), LDB,
$ CONE, A( K, K+KB ), LDA )
CALL ZTRSM( 'Right', UPLO, 'No transpose',
$ 'Non-unit', KB, N-K-KB+1, CONE,
$ B( K+KB, K+KB ), LDB, A( K, K+KB ),
$ LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L**H)
*
DO 20 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(k:n,k:n)
*
CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
IF( K+KB.LE.N ) THEN
CALL ZTRSM( 'Right', UPLO, 'Conjugate transpose',
$ 'Non-unit', N-K-KB+1, KB, CONE,
$ B( K, K ), LDB, A( K+KB, K ), LDA )
CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB,
$ CONE, A( K+KB, K ), LDA )
CALL ZHER2K( UPLO, 'No transpose', N-K-KB+1, KB,
$ -CONE, A( K+KB, K ), LDA,
$ B( K+KB, K ), LDB, ONE,
$ A( K+KB, K+KB ), LDA )
CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
$ A( K, K ), LDA, B( K+KB, K ), LDB,
$ CONE, A( K+KB, K ), LDA )
CALL ZTRSM( 'Left', UPLO, 'No transpose',
$ 'Non-unit', N-K-KB+1, KB, CONE,
$ B( K+KB, K+KB ), LDB, A( K+KB, K ),
$ LDA )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U**H
*
DO 30 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
$ K-1, KB, CONE, B, LDB, A( 1, K ), LDA )
CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, CONE, A( 1, K ),
$ LDA )
CALL ZHER2K( UPLO, 'No transpose', K-1, KB, CONE,
$ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
$ LDA )
CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
$ LDA, B( 1, K ), LDB, CONE, A( 1, K ),
$ LDA )
CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose',
$ 'Non-unit', K-1, KB, CONE, B( K, K ), LDB,
$ A( 1, K ), LDA )
CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
30 CONTINUE
ELSE
*
* Compute L**H*A*L
*
DO 40 K = 1, N, NB
KB = MIN( N-K+1, NB )
*
* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
*
CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
$ KB, K-1, CONE, B, LDB, A( K, 1 ), LDA )
CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
$ LDA )
CALL ZHER2K( UPLO, 'Conjugate transpose', K-1, KB,
$ CONE, A( K, 1 ), LDA, B( K, 1 ), LDB,
$ ONE, A, LDA )
CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
$ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
$ LDA )
CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose',
$ 'Non-unit', KB, K-1, CONE, B( K, K ), LDB,
$ A( K, 1 ), LDA )
CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
$ B( K, K ), LDB, INFO )
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of ZHEGST
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zheevx.f 0000644 0000000 0000000 00000000132 14061636515 015335 x ustar 00 30 mtime=1623670093.243104044
30 atime=1623670093.242104045
30 ctime=1623670093.243104044
elk-7.2.42/src/LAPACK/zheevx.f 0000644 0025044 0025044 00000043344 14061636515 017402 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief ZHEEVX 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 ZHEEVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
* ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK,
* IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* CHARACTER JOBZ, RANGE, UPLO
* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IFAIL( * ), IWORK( * )
* DOUBLE PRECISION RWORK( * ), W( * )
* COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
*> of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
*> be selected by specifying either a range of values or a range of
*> indices for the desired eigenvalues.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOBZ
*> \verbatim
*> JOBZ is CHARACTER*1
*> = 'N': Compute eigenvalues only;
*> = 'V': Compute eigenvalues and eigenvectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': all eigenvalues will be found.
*> = 'V': all eigenvalues in the half-open interval (VL,VU]
*> will be found.
*> = 'I': the IL-th through IU-th eigenvalues will be found.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the
*> leading N-by-N upper triangular part of A contains the
*> upper triangular part of the matrix A. If UPLO = 'L',
*> the leading N-by-N lower triangular part of A contains
*> the lower triangular part of the matrix A.
*> On exit, 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[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute error tolerance for the eigenvalues.
*> An approximate eigenvalue is accepted as converged
*> when it is determined to lie in an interval [a,b]
*> of width less than or equal to
*>
*> ABSTOL + EPS * max( |a|,|b| ) ,
*>
*> where EPS is the machine precision. If ABSTOL is less than
*> or equal to zero, then EPS*|T| will be used in its place,
*> where |T| is the 1-norm of the tridiagonal matrix obtained
*> by reducing A to tridiagonal form.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> If this routine returns with INFO>0, indicating that some
*> eigenvectors did not converge, try setting ABSTOL to
*> 2*DLAMCH('S').
*>
*> See "Computing Small Singular Values of Bidiagonal Matrices
*> with Guaranteed High Relative Accuracy," by Demmel and
*> Kahan, LAPACK Working Note #3.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The total number of eigenvalues found. 0 <= M <= N.
*> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> On normal exit, the first M elements contain the selected
*> eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, max(1,M))
*> If JOBZ = 'V', then if INFO = 0, the first M columns of Z
*> contain the orthonormal eigenvectors of the matrix A
*> corresponding to the selected eigenvalues, with the i-th
*> column of Z holding the eigenvector associated with W(i).
*> If an eigenvector fails to converge, then that column of Z
*> contains the latest approximation to the eigenvector, and the
*> index of the eigenvector is returned in IFAIL.
*> If JOBZ = 'N', then Z is not referenced.
*> Note: the user must ensure that at least max(1,M) columns are
*> supplied in the array Z; if RANGE = 'V', the exact value of M
*> is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1, and if
*> JOBZ = 'V', LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The length of the array WORK. LWORK >= 1, when N <= 1;
*> otherwise 2*N.
*> For optimal efficiency, LWORK >= (NB+1)*N,
*> where NB is the max of the blocksize for ZHETRD and for
*> ZUNMTR as returned by ILAENV.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (7*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (N)
*> If JOBZ = 'V', then if INFO = 0, the first M elements of
*> IFAIL are zero. If INFO > 0, then IFAIL contains the
*> indices of the eigenvectors that failed to converge.
*> If JOBZ = 'N', then IFAIL 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: if INFO = i, then i eigenvectors failed to converge.
*> Their indices are stored in array IFAIL.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16HEeigen
*
* =====================================================================
SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
$ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK,
$ IWORK, IFAIL, INFO )
*
* -- LAPACK driver routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2016
*
* .. Scalar Arguments ..
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
$ WANTZ
CHARACTER ORDER
INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
$ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
$ ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB,
$ NSPLIT
DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
$ SIGMA, SMLNUM, TMP1, VLL, VUU
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, ZLANHE
EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
$ ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR,
$ ZUNMTR
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
LOWER = LSAME( UPLO, 'L' )
WANTZ = LSAME( JOBZ, 'V' )
ALLEIG = LSAME( RANGE, 'A' )
VALEIG = LSAME( RANGE, 'V' )
INDEIG = LSAME( RANGE, 'I' )
LQUERY = ( LWORK.EQ.-1 )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
INFO = -2
ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE
IF( VALEIG ) THEN
IF( N.GT.0 .AND. VU.LE.VL )
$ INFO = -8
ELSE IF( INDEIG ) THEN
IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
INFO = -10
END IF
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -15
END IF
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.LE.1 ) THEN
LWKMIN = 1
WORK( 1 ) = LWKMIN
ELSE
LWKMIN = 2*N
NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) )
LWKOPT = MAX( 1, ( NB + 1 )*N )
WORK( 1 ) = LWKOPT
END IF
*
IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
$ INFO = -17
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEEVX', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 ) THEN
RETURN
END IF
*
IF( N.EQ.1 ) THEN
IF( ALLEIG .OR. INDEIG ) THEN
M = 1
W( 1 ) = A( 1, 1 )
ELSE IF( VALEIG ) THEN
IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) )
$ THEN
M = 1
W( 1 ) = A( 1, 1 )
END IF
END IF
IF( WANTZ )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
* Scale matrix to allowable range, if necessary.
*
ISCALE = 0
ABSTLL = ABSTOL
IF( VALEIG ) THEN
VLL = VL
VUU = VU
END IF
ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
IF( LOWER ) THEN
DO 10 J = 1, N
CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 )
10 CONTINUE
ELSE
DO 20 J = 1, N
CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 )
20 CONTINUE
END IF
IF( ABSTOL.GT.0 )
$ ABSTLL = ABSTOL*SIGMA
IF( VALEIG ) THEN
VLL = VL*SIGMA
VUU = VU*SIGMA
END IF
END IF
*
* Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
*
INDD = 1
INDE = INDD + N
INDRWK = INDE + N
INDTAU = 1
INDWRK = INDTAU + N
LLWORK = LWORK - INDWRK + 1
CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ),
$ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
*
* If all eigenvalues are desired and ABSTOL is less than or equal to
* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for
* some eigenvalue, then try DSTEBZ.
*
TEST = .FALSE.
IF( INDEIG ) THEN
IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
TEST = .TRUE.
END IF
END IF
IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
INDEE = INDRWK + 2*N
IF( .NOT.WANTZ ) THEN
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL DSTERF( N, W, RWORK( INDEE ), INFO )
ELSE
CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ )
CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
$ WORK( INDWRK ), LLWORK, IINFO )
CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
IF( INFO.EQ.0 ) THEN
DO 30 I = 1, N
IFAIL( I ) = 0
30 CONTINUE
END IF
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 40
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
*
IF( WANTZ ) THEN
ORDER = 'B'
ELSE
ORDER = 'E'
END IF
INDIBL = 1
INDISP = INDIBL + N
INDIWK = INDISP + N
CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
$ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
$ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
$ IWORK( INDIWK ), INFO )
*
IF( WANTZ ) THEN
CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
$ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
$ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
*
* Apply unitary matrix used in reduction to tridiagonal
* form to eigenvectors returned by ZSTEIN.
*
CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
$ LDZ, WORK( INDWRK ), LLWORK, IINFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
40 CONTINUE
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = M
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
* If eigenvalues are not in order, then sort them, along with
* eigenvectors.
*
IF( WANTZ ) THEN
DO 60 J = 1, M - 1
I = 0
TMP1 = W( J )
DO 50 JJ = J + 1, M
IF( W( JJ ).LT.TMP1 ) THEN
I = JJ
TMP1 = W( JJ )
END IF
50 CONTINUE
*
IF( I.NE.0 ) THEN
ITMP1 = IWORK( INDIBL+I-1 )
W( I ) = W( J )
IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
W( J ) = TMP1
IWORK( INDIBL+J-1 ) = ITMP1
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
IF( INFO.NE.0 ) THEN
ITMP1 = IFAIL( I )
IFAIL( I ) = IFAIL( J )
IFAIL( J ) = ITMP1
END IF
END IF
60 CONTINUE
END IF
*
* Set WORK(1) to optimal complex workspace size.
*
WORK( 1 ) = LWKOPT
*
RETURN
*
* End of ZHEEVX
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlanhp.f 0000644 0000000 0000000 00000000132 14061636515 015320 x ustar 00 30 mtime=1623670093.245104042
30 atime=1623670093.245104042
30 ctime=1623670093.245104042
elk-7.2.42/src/LAPACK/zlanhp.f 0000644 0025044 0025044 00000021463 14061636515 017363 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix supplied in packed form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANHP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM, UPLO
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION WORK( * )
* COMPLEX*16 AP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLANHP returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> complex hermitian matrix A, supplied in packed form.
*> \endverbatim
*>
*> \return ZLANHP
*> \verbatim
*>
*> ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in ZLANHP as described
*> above.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> hermitian matrix A is supplied.
*> = 'U': Upper triangular part of A is supplied
*> = 'L': Lower triangular part of A is supplied
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, ZLANHP is
*> set to zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The upper or lower triangle of the hermitian matrix A, packed
*> columnwise in a linear array. The j-th column of A is stored
*> in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
*> WORK is not referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* -- 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
*
IMPLICIT NONE
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SUM, VALUE
* ..
* .. Local Arrays ..
DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ, DCOMBSSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 0
DO 20 J = 1, N
DO 10 I = K + 1, K + J - 1
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
10 CONTINUE
K = K + J
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
SUM = ABS( DBLE( AP( K ) ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
DO 30 I = K + 1, K + N - J
SUM = ABS( AP( I ) )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AP( K ) ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
SUM = WORK( I )
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( AP( K ) ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
* SSQ(1) is scale
* SSQ(2) is sum-of-squares
* For better accuracy, sum each column separately.
*
SSQ( 1 ) = ZERO
SSQ( 2 ) = ONE
*
* Sum off-diagonals
*
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL ZLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
CALL ZLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
CALL DCOMBSSQ( SSQ, COLSSQ )
K = K + N - J + 1
120 CONTINUE
END IF
SSQ( 2 ) = 2*SSQ( 2 )
*
* Sum diagonal
*
K = 1
COLSSQ( 1 ) = ZERO
COLSSQ( 2 ) = ONE
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( COLSSQ( 1 ).LT.ABSA ) THEN
COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2
COLSSQ( 1 ) = ABSA
ELSE
COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
CALL DCOMBSSQ( SSQ, COLSSQ )
VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
END IF
*
ZLANHP = VALUE
RETURN
*
* End of ZLANHP
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhptrd.f 0000644 0000000 0000000 00000000127 14061636515 015343 x ustar 00 29 mtime=1623670093.24710404
29 atime=1623670093.24710404
29 ctime=1623670093.24710404
elk-7.2.42/src/LAPACK/zhptrd.f 0000644 0025044 0025044 00000021630 14061636515 017376 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHPTRD
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHPTRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 AP( * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
*> real symmetric tridiagonal form T by a unitary similarity
*> transformation: Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> On entry, the upper or lower triangle of the Hermitian matrix
*> A, packed columnwise in a linear array. The j-th column of A
*> is stored in the array AP as follows:
*> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
*> of A are overwritten by the corresponding elements of the
*> tridiagonal matrix T, and the elements above the first
*> superdiagonal, with the array TAU, represent the unitary
*> matrix Q as a product of elementary reflectors; if UPLO
*> = 'L', the diagonal and first subdiagonal of A are over-
*> written by the corresponding elements of the tridiagonal
*> matrix T, and the elements below the first subdiagonal, with
*> the array TAU, represent the unitary matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n-1) . . . H(2) H(1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
*> overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(n-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
*> overwriting A(i+2:n,i), and tau is stored in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK computational routine (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 INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 AP( * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, I1, I1I1, II
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(1:i-1,i+1)
*
ALPHA = AP( I1+I-1 )
CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y**H *v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 )
CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
END IF
AP( I1+I-1 ) = E( I )
D( I+1 ) = AP( I1+I )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = AP( 1 )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
AP( 1 ) = DBLE( AP( 1 ) )
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(i+2:n,i)
*
ALPHA = AP( II+1 )
CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y**H *v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
END IF
AP( II+1 ) = E( I )
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of ZHPTRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zupgtr.f 0000644 0000000 0000000 00000000132 14061636515 015357 x ustar 00 30 mtime=1623670093.249104038
30 atime=1623670093.249104038
30 ctime=1623670093.249104038
elk-7.2.42/src/LAPACK/zupgtr.f 0000644 0025044 0025044 00000013732 14061636515 017422 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUPGTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUPGTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUPGTR generates a complex unitary matrix Q which is defined as the
*> product of n-1 elementary reflectors H(i) of order n, as returned by
*> ZHPTRD using packed storage:
*>
*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*>
*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangular packed storage used in previous
*> call to ZHPTRD;
*> = 'L': Lower triangular packed storage used in previous
*> call to ZHPTRD.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix Q. N >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension (N*(N+1)/2)
*> The vectors which define the elementary reflectors, as
*> returned by ZHPTRD.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZHPTRD.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> The N-by-N unitary matrix Q.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N-1)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, 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 UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNG2L, ZUNG2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = CZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = CZERO
30 CONTINUE
Q( N, N ) = CONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = CONE
DO 40 I = 2, N
Q( I, 1 ) = CZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = CZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of ZUPGTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dstebz.f 0000644 0000000 0000000 00000000132 14061636515 015317 x ustar 00 30 mtime=1623670093.251104036
30 atime=1623670093.251104036
30 ctime=1623670093.251104036
elk-7.2.42/src/LAPACK/dstebz.f 0000644 0025044 0025044 00000057162 14061636515 017367 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSTEBZ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEBZ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
* M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER ORDER, RANGE
* INTEGER IL, INFO, IU, M, N, NSPLIT
* DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
* INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSTEBZ computes the eigenvalues of a symmetric tridiagonal
*> matrix T. The user may ask for all eigenvalues, all eigenvalues
*> in the half-open interval (VL, VU], or the IL-th through IU-th
*> eigenvalues.
*>
*> To avoid overflow, the matrix must be scaled so that its
*> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
*> accuracy, it should not be much smaller than that.
*>
*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
*> Matrix", Report CS41, Computer Science Dept., Stanford
*> University, July 21, 1966.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] RANGE
*> \verbatim
*> RANGE is CHARACTER*1
*> = 'A': ("All") all eigenvalues will be found.
*> = 'V': ("Value") all eigenvalues in the half-open interval
*> (VL, VU] will be found.
*> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
*> entire matrix) will be found.
*> \endverbatim
*>
*> \param[in] ORDER
*> \verbatim
*> ORDER is CHARACTER*1
*> = 'B': ("By Block") the eigenvalues will be grouped by
*> split-off block (see IBLOCK, ISPLIT) and
*> ordered from smallest to largest within
*> the block.
*> = 'E': ("Entire matrix")
*> the eigenvalues for the entire matrix
*> will be ordered from smallest to
*> largest.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the tridiagonal matrix T. N >= 0.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*> VL is DOUBLE PRECISION
*>
*> If RANGE='V', the lower bound of the interval to
*> be searched for eigenvalues. Eigenvalues less than or equal
*> to VL, or greater than VU, will not be returned. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*> VU is DOUBLE PRECISION
*>
*> If RANGE='V', the upper bound of the interval to
*> be searched for eigenvalues. Eigenvalues less than or equal
*> to VL, or greater than VU, will not be returned. VL < VU.
*> Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*> IL is INTEGER
*>
*> If RANGE='I', the index of the
*> smallest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*> IU is INTEGER
*>
*> If RANGE='I', the index of the
*> largest eigenvalue to be returned.
*> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
*> Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The absolute tolerance for the eigenvalues. An eigenvalue
*> (or cluster) is considered to be located if it has been
*> determined to lie in an interval whose width is ABSTOL or
*> less. If ABSTOL is less than or equal to zero, then ULP*|T|
*> will be used, where |T| means the 1-norm of T.
*>
*> Eigenvalues will be computed most accurately when ABSTOL is
*> set to twice the underflow threshold 2*DLAMCH('S'), not zero.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The n diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The (n-1) off-diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*> M is INTEGER
*> The actual number of eigenvalues found. 0 <= M <= N.
*> (See also the description of INFO=2,3.)
*> \endverbatim
*>
*> \param[out] NSPLIT
*> \verbatim
*> NSPLIT is INTEGER
*> The number of diagonal blocks in the matrix T.
*> 1 <= NSPLIT <= N.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> On exit, the first M elements of W will contain the
*> eigenvalues. (DSTEBZ may use the remaining N-M elements as
*> workspace.)
*> \endverbatim
*>
*> \param[out] IBLOCK
*> \verbatim
*> IBLOCK is INTEGER array, dimension (N)
*> At each row/column j where E(j) is zero or small, the
*> matrix T is considered to split into a block diagonal
*> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
*> block (from 1 to the number of blocks) the eigenvalue W(i)
*> belongs. (DSTEBZ may use the remaining N-M elements as
*> workspace.)
*> \endverbatim
*>
*> \param[out] ISPLIT
*> \verbatim
*> ISPLIT is INTEGER array, dimension (N)
*> The splitting points, at which T breaks up into submatrices.
*> The first submatrix consists of rows/columns 1 to ISPLIT(1),
*> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*> etc., and the NSPLIT-th consists of rows/columns
*> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*> (Only the first NSPLIT elements will actually be used, but
*> since the user cannot know a priori what value NSPLIT will
*> have, N words must be reserved for ISPLIT.)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (4*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: some or all of the eigenvalues failed to converge or
*> were not computed:
*> =1 or 3: Bisection failed to converge for some
*> eigenvalues; these eigenvalues are flagged by a
*> negative block number. The effect is that the
*> eigenvalues may not be as accurate as the
*> absolute and relative tolerances. This is
*> generally caused by unexpectedly inaccurate
*> arithmetic.
*> =2 or 3: RANGE='I' only: Not all of the eigenvalues
*> IL:IU were found.
*> Effect: M < IU+1-IL
*> Cause: non-monotonic arithmetic, causing the
*> Sturm sequence to be non-monotonic.
*> Cure: recalculate, using RANGE='A', and pick
*> out eigenvalues IL:IU. In some cases,
*> increasing the PARAMETER "FUDGE" may
*> make things work.
*> = 4: RANGE='I', and the Gershgorin interval
*> initially used was too small. No eigenvalues
*> were computed.
*> Probable cause: your machine has sloppy
*> floating-point arithmetic.
*> Cure: Increase the PARAMETER "FUDGE",
*> recompile, and try again.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> RELFAC DOUBLE PRECISION, default = 2.0e0
*> The relative tolerance. An interval (a,b] lies within
*> "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
*> where "ulp" is the machine precision (distance from 1 to
*> the next larger floating point number.)
*>
*> FUDGE DOUBLE PRECISION, default = 2
*> A "fudge factor" to widen the Gershgorin intervals. Ideally,
*> a value of 1 should work, but on machines with sloppy
*> arithmetic, this needs to be larger. The default for
*> publicly released versions should be large enough to handle
*> the worst machine around. Note that this has no effect
*> on accuracy of the solution.
*> \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 DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
$ M, NSPLIT, W, IBLOCK, ISPLIT, 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 ..
CHARACTER ORDER, RANGE
INTEGER IL, INFO, IU, M, N, NSPLIT
DOUBLE PRECISION ABSTOL, VL, VU
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, HALF
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
DOUBLE PRECISION FUDGE, RELFAC
PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL NCNVRG, TOOFEW
INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
$ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
$ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
$ NWU
DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
$ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
* ..
* .. Local Arrays ..
INTEGER IDUMMA( 1 )
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, ILAENV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAEBZ, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Decode RANGE
*
IF( LSAME( RANGE, 'A' ) ) THEN
IRANGE = 1
ELSE IF( LSAME( RANGE, 'V' ) ) THEN
IRANGE = 2
ELSE IF( LSAME( RANGE, 'I' ) ) THEN
IRANGE = 3
ELSE
IRANGE = 0
END IF
*
* Decode ORDER
*
IF( LSAME( ORDER, 'B' ) ) THEN
IORDER = 2
ELSE IF( LSAME( ORDER, 'E' ) ) THEN
IORDER = 1
ELSE
IORDER = 0
END IF
*
* Check for Errors
*
IF( IRANGE.LE.0 ) THEN
INFO = -1
ELSE IF( IORDER.LE.0 ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( IRANGE.EQ.2 ) THEN
IF( VL.GE.VU )
$ INFO = -5
ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
$ THEN
INFO = -6
ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
$ THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEBZ', -INFO )
RETURN
END IF
*
* Initialize error flags
*
INFO = 0
NCNVRG = .FALSE.
TOOFEW = .FALSE.
*
* Quick return if possible
*
M = 0
IF( N.EQ.0 )
$ RETURN
*
* Simplifications:
*
IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
$ IRANGE = 1
*
* Get machine constants
* NB is the minimum vector length for vector bisection, or 0
* if only scalar is to be done.
*
SAFEMN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
RTOLI = ULP*RELFAC
NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
IF( NB.LE.1 )
$ NB = 0
*
* Special Case when N=1
*
IF( N.EQ.1 ) THEN
NSPLIT = 1
ISPLIT( 1 ) = 1
IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
M = 0
ELSE
W( 1 ) = D( 1 )
IBLOCK( 1 ) = 1
M = 1
END IF
RETURN
END IF
*
* Compute Splitting Points
*
NSPLIT = 1
WORK( N ) = ZERO
PIVMIN = ONE
*
DO 10 J = 2, N
TMP1 = E( J-1 )**2
IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
ISPLIT( NSPLIT ) = J - 1
NSPLIT = NSPLIT + 1
WORK( J-1 ) = ZERO
ELSE
WORK( J-1 ) = TMP1
PIVMIN = MAX( PIVMIN, TMP1 )
END IF
10 CONTINUE
ISPLIT( NSPLIT ) = N
PIVMIN = PIVMIN*SAFEMN
*
* Compute Interval and ATOLI
*
IF( IRANGE.EQ.3 ) THEN
*
* RANGE='I': Compute the interval containing eigenvalues
* IL through IU.
*
* Compute Gershgorin interval for entire (split) matrix
* and use it as the initial interval
*
GU = D( 1 )
GL = D( 1 )
TMP1 = ZERO
*
DO 20 J = 1, N - 1
TMP2 = SQRT( WORK( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
20 CONTINUE
*
GU = MAX( GU, D( N )+TMP1 )
GL = MIN( GL, D( N )-TMP1 )
TNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
* Compute Iteration parameters
*
ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
WORK( N+1 ) = GL
WORK( N+2 ) = GL
WORK( N+3 ) = GU
WORK( N+4 ) = GU
WORK( N+5 ) = GL
WORK( N+6 ) = GU
IWORK( 1 ) = -1
IWORK( 2 ) = -1
IWORK( 3 ) = N + 1
IWORK( 4 ) = N + 1
IWORK( 5 ) = IL - 1
IWORK( 6 ) = IU
*
CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
$ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
$ IWORK, W, IBLOCK, IINFO )
*
IF( IWORK( 6 ).EQ.IU ) THEN
WL = WORK( N+1 )
WLU = WORK( N+3 )
NWL = IWORK( 1 )
WU = WORK( N+4 )
WUL = WORK( N+2 )
NWU = IWORK( 4 )
ELSE
WL = WORK( N+2 )
WLU = WORK( N+4 )
NWL = IWORK( 2 )
WU = WORK( N+3 )
WUL = WORK( N+1 )
NWU = IWORK( 3 )
END IF
*
IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
INFO = 4
RETURN
END IF
ELSE
*
* RANGE='A' or 'V' -- Set ATOLI
*
TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( D( N ) )+ABS( E( N-1 ) ) )
*
DO 30 J = 2, N - 1
TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
$ ABS( E( J ) ) )
30 CONTINUE
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*TNORM
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.EQ.2 ) THEN
WL = VL
WU = VU
ELSE
WL = ZERO
WU = ZERO
END IF
END IF
*
* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
* NWL accumulates the number of eigenvalues .le. WL,
* NWU accumulates the number of eigenvalues .le. WU
*
M = 0
IEND = 0
INFO = 0
NWL = 0
NWU = 0
*
DO 70 JB = 1, NSPLIT
IOFF = IEND
IBEGIN = IOFF + 1
IEND = ISPLIT( JB )
IN = IEND - IOFF
*
IF( IN.EQ.1 ) THEN
*
* Special Case -- IN=1
*
IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
$ NWL = NWL + 1
IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
$ NWU = NWU + 1
IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
$ D( IBEGIN )-PIVMIN ) ) THEN
M = M + 1
W( M ) = D( IBEGIN )
IBLOCK( M ) = JB
END IF
ELSE
*
* General Case -- IN > 1
*
* Compute Gershgorin Interval
* and use it as the initial interval
*
GU = D( IBEGIN )
GL = D( IBEGIN )
TMP1 = ZERO
*
DO 40 J = IBEGIN, IEND - 1
TMP2 = ABS( E( J ) )
GU = MAX( GU, D( J )+TMP1+TMP2 )
GL = MIN( GL, D( J )-TMP1-TMP2 )
TMP1 = TMP2
40 CONTINUE
*
GU = MAX( GU, D( IEND )+TMP1 )
GL = MIN( GL, D( IEND )-TMP1 )
BNORM = MAX( ABS( GL ), ABS( GU ) )
GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
*
* Compute ATOLI for the current submatrix
*
IF( ABSTOL.LE.ZERO ) THEN
ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
ELSE
ATOLI = ABSTOL
END IF
*
IF( IRANGE.GT.1 ) THEN
IF( GU.LT.WL ) THEN
NWL = NWL + IN
NWU = NWU + IN
GO TO 70
END IF
GL = MAX( GL, WL )
GU = MIN( GU, WU )
IF( GL.GE.GU )
$ GO TO 70
END IF
*
* Set Up Initial Interval
*
WORK( N+1 ) = GL
WORK( N+IN+1 ) = GU
CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
NWL = NWL + IWORK( 1 )
NWU = NWU + IWORK( IN+1 )
IWOFF = M - IWORK( 1 )
*
* Compute Eigenvalues
*
ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
$ LOG( TWO ) ) + 2
CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
$ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
$ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
$ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
*
* Copy Eigenvalues Into W and IBLOCK
* Use -JB for block number for unconverged eigenvalues.
*
DO 60 J = 1, IOUT
TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
*
* Flag non-convergence.
*
IF( J.GT.IOUT-IINFO ) THEN
NCNVRG = .TRUE.
IB = -JB
ELSE
IB = JB
END IF
DO 50 JE = IWORK( J ) + 1 + IWOFF,
$ IWORK( J+IN ) + IWOFF
W( JE ) = TMP1
IBLOCK( JE ) = IB
50 CONTINUE
60 CONTINUE
*
M = M + IM
END IF
70 CONTINUE
*
* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
*
IF( IRANGE.EQ.3 ) THEN
IM = 0
IDISCL = IL - 1 - NWL
IDISCU = NWU - IU
*
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
DO 80 JE = 1, M
IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
IDISCL = IDISCL - 1
ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
IDISCU = IDISCU - 1
ELSE
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
80 CONTINUE
M = IM
END IF
IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
*
* Code to deal with effects of bad arithmetic:
* Some low eigenvalues to be discarded are not in (WL,WLU],
* or high eigenvalues to be discarded are not in (WUL,WU]
* so just kill off the smallest IDISCL/largest IDISCU
* eigenvalues, by simply finding the smallest/largest
* eigenvalue(s).
*
* (If N(w) is monotone non-decreasing, this should never
* happen.)
*
IF( IDISCL.GT.0 ) THEN
WKILL = WU
DO 100 JDISC = 1, IDISCL
IW = 0
DO 90 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
90 CONTINUE
IBLOCK( IW ) = 0
100 CONTINUE
END IF
IF( IDISCU.GT.0 ) THEN
*
WKILL = WL
DO 120 JDISC = 1, IDISCU
IW = 0
DO 110 JE = 1, M
IF( IBLOCK( JE ).NE.0 .AND.
$ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
IW = JE
WKILL = W( JE )
END IF
110 CONTINUE
IBLOCK( IW ) = 0
120 CONTINUE
END IF
IM = 0
DO 130 JE = 1, M
IF( IBLOCK( JE ).NE.0 ) THEN
IM = IM + 1
W( IM ) = W( JE )
IBLOCK( IM ) = IBLOCK( JE )
END IF
130 CONTINUE
M = IM
END IF
IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
TOOFEW = .TRUE.
END IF
END IF
*
* If ORDER='B', do nothing -- the eigenvalues are already sorted
* by block.
* If ORDER='E', sort the eigenvalues from smallest to largest
*
IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
DO 150 JE = 1, M - 1
IE = 0
TMP1 = W( JE )
DO 140 J = JE + 1, M
IF( W( J ).LT.TMP1 ) THEN
IE = J
TMP1 = W( J )
END IF
140 CONTINUE
*
IF( IE.NE.0 ) THEN
ITMP1 = IBLOCK( IE )
W( IE ) = W( JE )
IBLOCK( IE ) = IBLOCK( JE )
W( JE ) = TMP1
IBLOCK( JE ) = ITMP1
END IF
150 CONTINUE
END IF
*
INFO = 0
IF( NCNVRG )
$ INFO = INFO + 1
IF( TOOFEW )
$ INFO = INFO + 2
RETURN
*
* End of DSTEBZ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zstein.f 0000644 0000000 0000000 00000000132 14061636515 015340 x ustar 00 30 mtime=1623670093.253104035
30 atime=1623670093.253104035
30 ctime=1623670093.253104035
elk-7.2.42/src/LAPACK/zstein.f 0000644 0025044 0025044 00000033420 14061636515 017377 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZSTEIN
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZSTEIN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
* IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
* $ IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
* COMPLEX*16 Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZSTEIN computes the eigenvectors of a real symmetric tridiagonal
*> matrix T corresponding to specified eigenvalues, using inverse
*> iteration.
*>
*> The maximum number of iterations allowed for each eigenvector is
*> specified by an internal parameter MAXITS (currently set to 5).
*>
*> Although the eigenvectors are real, they are stored in a complex
*> array, which may be passed to ZUNMTR or ZUPMTR for back
*> transformation to the eigenvectors of a complex Hermitian matrix
*> which was reduced to tridiagonal form.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The n diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The (n-1) subdiagonal elements of the tridiagonal matrix
*> T, stored in elements 1 to N-1.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of eigenvectors to be found. 0 <= M <= N.
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> The first M elements of W contain the eigenvalues for
*> which eigenvectors are to be computed. The eigenvalues
*> should be grouped by split-off block and ordered from
*> smallest to largest within the block. ( The output array
*> W from DSTEBZ with ORDER = 'B' is expected here. )
*> \endverbatim
*>
*> \param[in] IBLOCK
*> \verbatim
*> IBLOCK is INTEGER array, dimension (N)
*> The submatrix indices associated with the corresponding
*> eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
*> the first submatrix from the top, =2 if W(i) belongs to
*> the second submatrix, etc. ( The output array IBLOCK
*> from DSTEBZ is expected here. )
*> \endverbatim
*>
*> \param[in] ISPLIT
*> \verbatim
*> ISPLIT is INTEGER array, dimension (N)
*> The splitting points, at which T breaks up into submatrices.
*> The first submatrix consists of rows/columns 1 to
*> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
*> through ISPLIT( 2 ), etc.
*> ( The output array ISPLIT from DSTEBZ is expected here. )
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ, M)
*> The computed eigenvectors. The eigenvector associated
*> with the eigenvalue W(i) is stored in the i-th column of
*> Z. Any vector which fails to converge is set to its current
*> iterate after MAXITS iterations.
*> The imaginary parts of the eigenvectors are set to zero.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (M)
*> On normal exit, all elements of IFAIL are zero.
*> If one or more eigenvectors fail to converge after
*> MAXITS iterations, then their indices are stored in
*> array IFAIL.
*> \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, then i eigenvectors failed to converge
*> in MAXITS iterations. Their indices are stored in
*> array IFAIL.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> MAXITS INTEGER, default = 5
*> The maximum number of iterations performed.
*>
*> EXTRA INTEGER, default = 2
*> The number of iterations performed after norm growth
*> criterion is satisfied, should be at least 1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, 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, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, JR, NBLK, NRMCHK
DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, TOL, XJ, XJM, ZTR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DNRM2
EXTERNAL IDAMAX, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEIN', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = CONE
RETURN
END IF
*
* Get machine constants.
*
EPS = DLAMCH( 'Precision' )
*
* Initialize seed for random number generator DLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 180 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = J1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
DTPCRT = SQRT( ODM1 / BLKSIZ )
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 170 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 180
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 140
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 120
*
* Normalize and scale the righthand side vector Pb.
*
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ ABS( WORK( INDRV1+JMAX ) )
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 110
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 100 I = GPIND, J - 1
ZTR = ZERO
DO 80 JR = 1, BLKSIZ
ZTR = ZTR + WORK( INDRV1+JR )*
$ DBLE( Z( B1-1+JR, I ) )
80 CONTINUE
DO 90 JR = 1, BLKSIZ
WORK( INDRV1+JR ) = WORK( INDRV1+JR ) -
$ ZTR*DBLE( Z( B1-1+JR, I ) )
90 CONTINUE
100 CONTINUE
END IF
*
* Check the infinity norm of the iterate.
*
110 CONTINUE
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.DTPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 130
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
120 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
130 CONTINUE
SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
140 CONTINUE
DO 150 I = 1, N
Z( I, J ) = CZERO
150 CONTINUE
DO 160 I = 1, BLKSIZ
Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO )
160 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
170 CONTINUE
180 CONTINUE
*
RETURN
*
* End of ZSTEIN
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zupmtr.f 0000644 0000000 0000000 00000000132 14061636515 015365 x ustar 00 30 mtime=1623670093.255104033
30 atime=1623670093.255104033
30 ctime=1623670093.255104033
elk-7.2.42/src/LAPACK/zupmtr.f 0000644 0025044 0025044 00000021554 14061636515 017431 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUPMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUPMTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS, UPLO
* INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUPMTR 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 ZHPTRD using packed
*> storage:
*>
*> 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 triangular packed storage used in previous
*> call to ZHPTRD;
*> = 'L': Lower triangular packed storage used in previous
*> call to ZHPTRD.
*> \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] AP
*> \verbatim
*> AP is COMPLEX*16 array, dimension
*> (M*(M+1)/2) if SIDE = 'L'
*> (N*(N+1)/2) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by ZHPTRD. AP is modified by the routine but
*> restored on exit.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (M-1) if SIDE = 'L'
*> or (N-1) if SIDE = 'R'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZHPTRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L'
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, 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 SIDE, TRANS, UPLO
INTEGER INFO, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL FORWRD, LEFT, NOTRAN, UPPER
INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
UPPER = LSAME( UPLO, 'U' )
*
* 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.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -3
ELSE IF( M.LT.0 ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPMTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
FORWRD = ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 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:i,1:n)
*
MI = I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,1:i)
*
NI = I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = AP( II )
AP( II ) = ONE
CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
$ WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + I + 2
ELSE
II = II - I - 1
END IF
10 CONTINUE
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN )
*
IF( FORWRD ) THEN
I1 = 1
I2 = NQ - 1
I3 = 1
II = 2
ELSE
I1 = NQ - 1
I2 = 1
I3 = -1
II = NQ*( NQ+1 ) / 2 - 1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 20 I = I1, I2, I3
AII = AP( II )
AP( II ) = ONE
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i+1:m,1:n)
*
MI = M - I
IC = I + 1
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,i+1:n)
*
NI = N - I
JC = I + 1
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
$ LDC, WORK )
AP( II ) = AII
*
IF( FORWRD ) THEN
II = II + NQ - I + 1
ELSE
II = II - NQ + I - 2
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZUPMTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed1.f 0000644 0000000 0000000 00000000132 14061636515 015156 x ustar 00 30 mtime=1623670093.257104031
30 atime=1623670093.257104031
30 ctime=1623670093.257104031
elk-7.2.42/src/LAPACK/dlaed1.f 0000644 0025044 0025044 00000020435 14061636515 017217 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED1 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 DLAED1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER CUTPNT, INFO, LDQ, N
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER INDXQ( * ), IWORK( * )
* DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED1 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. DLAED7 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 DLAED2.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine DLAED4 (as called by DLAED3).
*> 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 DOUBLE PRECISION array, dimension (N)
*> On entry, the eigenvalues of the rank-1-perturbed matrix.
*> On exit, the eigenvalues of the repaired matrix.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is DOUBLE PRECISION 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 DOUBLE PRECISION
*> 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 DOUBLE PRECISION 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 DLAED1( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER INDXQ( * ), IWORK( * )
DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
$ IW, IZ, K, N1, N2, ZPP1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, 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( 'DLAED1', -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 DLAED2 and DLAED3.
*
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 DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
ZPP1 = CUTPNT + 1
CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
*
* Deflate eigenvalues.
*
CALL DLAED2( 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 DLAED3( 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 DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
DO 10 I = 1, N
INDXQ( I ) = I
10 CONTINUE
END IF
*
20 CONTINUE
RETURN
*
* End of DLAED1
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlassq.f 0000644 0000000 0000000 00000000132 14061636515 015313 x ustar 00 30 mtime=1623670093.259104029
30 atime=1623670093.259104029
30 ctime=1623670093.259104029
elk-7.2.42/src/LAPACK/dlassq.f 0000644 0025044 0025044 00000010374 14061636515 017355 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASSQ updates a sum of squares represented in scaled form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASSQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
* DOUBLE PRECISION X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASSQ returns the values scl and smsq such that
*>
*> ( scl**2 )*smsq = 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 and scl returns the value
*>
*> scl = max( scale, abs( x( i ) ) ).
*>
*> scale and sumsq must be supplied in SCALE and SUMSQ and
*> scl and smsq are overwritten on SCALE and SUMSQ respectively.
*>
*> The routine makes only one pass through the vector x.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements to be used from the vector X.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension (1+(N-1)*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.
*> INCX > 0.
*> \endverbatim
*>
*> \param[in,out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On entry, the value scale in the equation above.
*> On exit, SCALE is overwritten with scl , the scaling factor
*> for the sum of squares.
*> \endverbatim
*>
*> \param[in,out] SUMSQ
*> \verbatim
*> SUMSQ is DOUBLE PRECISION
*> On entry, the value sumsq in the equation above.
*> On exit, SUMSQ is overwritten with smsq , the basic sum of
*> squares from which scl has been factored out.
*> \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 DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- 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 ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION ABSXI
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
ABSXI = ABS( X( IX ) )
IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN
IF( SCALE.LT.ABSXI ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
SCALE = ABSXI
ELSE
SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
RETURN
*
* End of DLASSQ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dcombssq.f 0000644 0000000 0000000 00000000132 14061636515 015637 x ustar 00 30 mtime=1623670093.261104027
30 atime=1623670093.261104027
30 ctime=1623670093.261104027
elk-7.2.42/src/LAPACK/dcombssq.f 0000644 0025044 0025044 00000004234 14061636515 017677 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DCOMBSSQ adds two scaled sum of squares quantities.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*
* Definition:
* ===========
*
* SUBROUTINE DCOMBSSQ( V1, V2 )
*
* .. Array Arguments ..
* DOUBLE PRECISION V1( 2 ), V2( 2 )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2.
*> That is,
*>
*> V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq
*> + V2_scale**2 * V2_sumsq
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in,out] V1
*> \verbatim
*> V1 is DOUBLE PRECISION array, dimension (2).
*> The first scaled sum.
*> V1(1) = V1_scale, V1(2) = V1_sumsq.
*> \endverbatim
*>
*> \param[in] V2
*> \verbatim
*> V2 is DOUBLE PRECISION array, dimension (2).
*> The second scaled sum.
*> V2(1) = V2_scale, V2(2) = V2_sumsq.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2018
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
SUBROUTINE DCOMBSSQ( V1, V2 )
*
* -- 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..--
* November 2018
*
* .. Array Arguments ..
DOUBLE PRECISION V1( 2 ), V2( 2 )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Executable Statements ..
*
IF( V1( 1 ).GE.V2( 1 ) ) THEN
IF( V1( 1 ).NE.ZERO ) THEN
V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 )
END IF
ELSE
V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 )
V1( 1 ) = V2( 1 )
END IF
RETURN
*
* End of DCOMBSSQ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorgql.f 0000644 0000000 0000000 00000000132 14061636515 015314 x ustar 00 30 mtime=1623670093.263104025
30 atime=1623670093.262104026
30 ctime=1623670093.263104025
elk-7.2.42/src/LAPACK/dorgql.f 0000644 0025044 0025044 00000020006 14061636515 017347 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORGQL generates an M-by-N real matrix Q with orthonormal columns,
*> which is defined as the last N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by DGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGEQLF in the last k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, 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, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
$ NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk columns are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(m-kk+1:m,1:n-kk) to zero.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL DLARFB( 'Left', 'No transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows 1:m-k+i+ib-1 of current block
*
CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* Set rows m-k+i+ib:m of current block to zero
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGQL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorgqr.f 0000644 0000000 0000000 00000000132 14061636515 015322 x ustar 00 30 mtime=1623670093.264104024
30 atime=1623670093.264104024
30 ctime=1623670093.264104024
elk-7.2.42/src/LAPACK/dorgqr.f 0000644 0025044 0025044 00000017610 14061636515 017364 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORGQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORGQR generates an M-by-N real matrix Q with orthonormal columns,
*> which is defined as the first N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGEQRF in the first k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, 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, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
$ LWKOPT, NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
LWKOPT = MAX( 1, N )*NB
WORK( 1 ) = LWKOPT
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the last block.
* The first kk columns are handled by the block method.
*
KI = ( ( K-NX-1 ) / NB )*NB
KK = MIN( K, KI+NB )
*
* Set A(1:kk,kk+1:n) to zero.
*
DO 20 J = KK + 1, N
DO 10 I = 1, KK
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the last or only block.
*
IF( KK.LT.N )
$ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
$ TAU( KK+1 ), WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = KI + 1, 1, -NB
IB = MIN( NB, K-I+1 )
IF( I+IB.LE.N ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
$ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(i:m,i+ib:n) from the left
*
CALL DLARFB( 'Left', 'No transpose', 'Forward',
$ 'Columnwise', M-I+1, N-I-IB+1, IB,
$ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
$ LDA, WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows i:m of current block
*
CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
$ IINFO )
*
* Set rows 1:i-1 of current block to zero
*
DO 40 J = I, I + IB - 1
DO 30 L = 1, I - 1
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of DORGQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dpotrf2.f 0000644 0000000 0000000 00000000132 14061636515 015404 x ustar 00 30 mtime=1623670093.266104023
30 atime=1623670093.266104023
30 ctime=1623670093.266104023
elk-7.2.42/src/LAPACK/dpotrf2.f 0000644 0025044 0025044 00000014256 14061636515 017451 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DPOTRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* REAL A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DPOTRF2 computes the Cholesky factorization of a real symmetric
*> positive definite matrix A using the recursive algorithm.
*>
*> The factorization has the form
*> A = U**T * U, if UPLO = 'U', or
*> A = L * L**T, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = n/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> The subroutine calls itself to factor A11. Update and scale A21
*> or A12, update A22 then calls itself to factor A22.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**T*U or A = L*L**T.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doublePOcomputational
*
* =====================================================================
RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, 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 UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER N1, N2, IINFO
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DSYRK, DTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DPOTRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* N=1 case
*
IF( N.EQ.1 ) THEN
*
* Test for non-positive-definiteness
*
IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN
INFO = 1
RETURN
END IF
*
* Factor
*
A( 1, 1 ) = SQRT( A( 1, 1 ) )
*
* Use recursive code
*
ELSE
N1 = N/2
N2 = N-N1
*
* Factor A11
*
CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Compute the Cholesky factorization A = U**T*U
*
IF( UPPER ) THEN
*
* Update and scale A12
*
CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE,
$ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA )
*
* Update and factor A22
*
CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
*
* Compute the Cholesky factorization A = L*L**T
*
ELSE
*
* Update and scale A21
*
CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE,
$ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA )
*
* Update and factor A22
*
CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
END IF
END IF
RETURN
*
* End of DPOTRF2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaebz.f 0000644 0000000 0000000 00000000132 14061636515 015265 x ustar 00 30 mtime=1623670093.268104021
30 atime=1623670093.268104021
30 ctime=1623670093.268104021
elk-7.2.42/src/LAPACK/dlaebz.f 0000644 0025044 0025044 00000054020 14061636515 017323 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAEBZ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
* RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
* NAB, WORK, IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
* DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
* INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
* DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAEBZ contains the iteration loops which compute and use the
*> function N(w), which is the count of eigenvalues of a symmetric
*> tridiagonal matrix T less than or equal to its argument w. It
*> performs a choice of two types of loops:
*>
*> IJOB=1, followed by
*> IJOB=2: It takes as input a list of intervals and returns a list of
*> sufficiently small intervals whose union contains the same
*> eigenvalues as the union of the original intervals.
*> The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
*> The output interval (AB(j,1),AB(j,2)] will contain
*> eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
*>
*> IJOB=3: It performs a binary search in each input interval
*> (AB(j,1),AB(j,2)] for a point w(j) such that
*> N(w(j))=NVAL(j), and uses C(j) as the starting point of
*> the search. If such a w(j) is found, then on output
*> AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
*> (AB(j,1),AB(j,2)] will be a small interval containing the
*> point where N(w) jumps through NVAL(j), unless that point
*> lies outside the initial interval.
*>
*> Note that the intervals are in all cases half-open intervals,
*> i.e., of the form (a,b] , which includes b but not a .
*>
*> To avoid underflow, the matrix should be scaled so that its largest
*> element is no greater than overflow**(1/2) * underflow**(1/4)
*> in absolute value. To assure the most accurate computation
*> of small eigenvalues, the matrix should be scaled to be
*> not much smaller than that, either.
*>
*> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
*> Matrix", Report CS41, Computer Science Dept., Stanford
*> University, July 21, 1966
*>
*> Note: the arguments are, in general, *not* checked for unreasonable
*> values.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> Specifies what is to be done:
*> = 1: Compute NAB for the initial intervals.
*> = 2: Perform bisection iteration to find eigenvalues of T.
*> = 3: Perform bisection iteration to invert N(w), i.e.,
*> to find a point which has a specified number of
*> eigenvalues of T to its left.
*> Other values will cause DLAEBZ to return with INFO=-1.
*> \endverbatim
*>
*> \param[in] NITMAX
*> \verbatim
*> NITMAX is INTEGER
*> The maximum number of "levels" of bisection to be
*> performed, i.e., an interval of width W will not be made
*> smaller than 2^(-NITMAX) * W. If not all intervals
*> have converged after NITMAX iterations, then INFO is set
*> to the number of non-converged intervals.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension n of the tridiagonal matrix T. It must be at
*> least 1.
*> \endverbatim
*>
*> \param[in] MMAX
*> \verbatim
*> MMAX is INTEGER
*> The maximum number of intervals. If more than MMAX intervals
*> are generated, then DLAEBZ will quit with INFO=MMAX+1.
*> \endverbatim
*>
*> \param[in] MINP
*> \verbatim
*> MINP is INTEGER
*> The initial number of intervals. It may not be greater than
*> MMAX.
*> \endverbatim
*>
*> \param[in] NBMIN
*> \verbatim
*> NBMIN is INTEGER
*> The smallest number of intervals that should be processed
*> using a vector loop. If zero, then only the scalar loop
*> will be used.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*> ABSTOL is DOUBLE PRECISION
*> The minimum (absolute) width of an interval. When an
*> interval is narrower than ABSTOL, or than RELTOL times the
*> larger (in magnitude) endpoint, then it is considered to be
*> sufficiently small, i.e., converged. This must be at least
*> zero.
*> \endverbatim
*>
*> \param[in] RELTOL
*> \verbatim
*> RELTOL is DOUBLE PRECISION
*> The minimum relative width of an interval. When an interval
*> is narrower than ABSTOL, or than RELTOL times the larger (in
*> magnitude) endpoint, then it is considered to be
*> sufficiently small, i.e., converged. Note: this should
*> always be at least radix*machine epsilon.
*> \endverbatim
*>
*> \param[in] PIVMIN
*> \verbatim
*> PIVMIN is DOUBLE PRECISION
*> The minimum absolute value of a "pivot" in the Sturm
*> sequence loop.
*> This must be at least max |e(j)**2|*safe_min and at
*> least safe_min, where safe_min is at least
*> the smallest number that can divide one without overflow.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N)
*> The offdiagonal elements of the tridiagonal matrix T in
*> positions 1 through N-1. E(N) is arbitrary.
*> \endverbatim
*>
*> \param[in] E2
*> \verbatim
*> E2 is DOUBLE PRECISION array, dimension (N)
*> The squares of the offdiagonal elements of the tridiagonal
*> matrix T. E2(N) is ignored.
*> \endverbatim
*>
*> \param[in,out] NVAL
*> \verbatim
*> NVAL is INTEGER array, dimension (MINP)
*> If IJOB=1 or 2, not referenced.
*> If IJOB=3, the desired values of N(w). The elements of NVAL
*> will be reordered to correspond with the intervals in AB.
*> Thus, NVAL(j) on output will not, in general be the same as
*> NVAL(j) on input, but it will correspond with the interval
*> (AB(j,1),AB(j,2)] on output.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*> AB is DOUBLE PRECISION array, dimension (MMAX,2)
*> The endpoints of the intervals. AB(j,1) is a(j), the left
*> endpoint of the j-th interval, and AB(j,2) is b(j), the
*> right endpoint of the j-th interval. The input intervals
*> will, in general, be modified, split, and reordered by the
*> calculation.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (MMAX)
*> If IJOB=1, ignored.
*> If IJOB=2, workspace.
*> If IJOB=3, then on input C(j) should be initialized to the
*> first search point in the binary search.
*> \endverbatim
*>
*> \param[out] MOUT
*> \verbatim
*> MOUT is INTEGER
*> If IJOB=1, the number of eigenvalues in the intervals.
*> If IJOB=2 or 3, the number of intervals output.
*> If IJOB=3, MOUT will equal MINP.
*> \endverbatim
*>
*> \param[in,out] NAB
*> \verbatim
*> NAB is INTEGER array, dimension (MMAX,2)
*> If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
*> If IJOB=2, then on input, NAB(i,j) should be set. It must
*> satisfy the condition:
*> N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
*> which means that in interval i only eigenvalues
*> NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
*> NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
*> IJOB=1.
*> On output, NAB(i,j) will contain
*> max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
*> the input interval that the output interval
*> (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
*> the input values of NAB(k,1) and NAB(k,2).
*> If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
*> unless N(w) > NVAL(i) for all search points w , in which
*> case NAB(i,1) will not be modified, i.e., the output
*> value will be the same as the input value (modulo
*> reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
*> for all search points w , in which case NAB(i,2) will
*> not be modified. Normally, NAB should be set to some
*> distinctive value(s) before DLAEBZ is called.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MMAX)
*> Workspace.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (MMAX)
*> Workspace.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: All intervals converged.
*> = 1--MMAX: The last INFO intervals did not converge.
*> = MMAX+1: More than MMAX intervals were generated.
*> \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
*>
*> This routine is intended to be called only by other LAPACK
*> routines, thus the interface is less user-friendly. It is intended
*> for two purposes:
*>
*> (a) finding eigenvalues. In this case, DLAEBZ should have one or
*> more initial intervals set up in AB, and DLAEBZ should be called
*> with IJOB=1. This sets up NAB, and also counts the eigenvalues.
*> Intervals with no eigenvalues would usually be thrown out at
*> this point. Also, if not all the eigenvalues in an interval i
*> are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
*> For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
*> eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX
*> no smaller than the value of MOUT returned by the call with
*> IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
*> through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
*> tolerance specified by ABSTOL and RELTOL.
*>
*> (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
*> In this case, start with a Gershgorin interval (a,b). Set up
*> AB to contain 2 search intervals, both initially (a,b). One
*> NVAL element should contain f-1 and the other should contain l
*> , while C should contain a and b, resp. NAB(i,1) should be -1
*> and NAB(i,2) should be N+1, to flag an error if the desired
*> interval does not lie in (a,b). DLAEBZ is then called with
*> IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
*> j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
*> if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
*> >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
*> N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
*> w(l-r)=...=w(l+k) are handled similarly.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
$ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
$ NAB, WORK, IWORK, 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..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
* ..
* .. Array Arguments ..
INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, TWO, HALF
PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
$ HALF = 1.0D0 / TWO )
* ..
* .. Local Scalars ..
INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
$ KLNEW
DOUBLE PRECISION TMP1, TMP2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
* Check for Errors
*
INFO = 0
IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
INFO = -1
RETURN
END IF
*
* Initialize NAB
*
IF( IJOB.EQ.1 ) THEN
*
* Compute the number of eigenvalues in the initial intervals.
*
MOUT = 0
DO 30 JI = 1, MINP
DO 20 JP = 1, 2
TMP1 = D( 1 ) - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
NAB( JI, JP ) = 0
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = 1
*
DO 10 J = 2, N
TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
IF( ABS( TMP1 ).LT.PIVMIN )
$ TMP1 = -PIVMIN
IF( TMP1.LE.ZERO )
$ NAB( JI, JP ) = NAB( JI, JP ) + 1
10 CONTINUE
20 CONTINUE
MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
30 CONTINUE
RETURN
END IF
*
* Initialize for loop
*
* KF and KL have the following meaning:
* Intervals 1,...,KF-1 have converged.
* Intervals KF,...,KL still need to be refined.
*
KF = 1
KL = MINP
*
* If IJOB=2, initialize C.
* If IJOB=3, use the user-supplied starting point.
*
IF( IJOB.EQ.2 ) THEN
DO 40 JI = 1, MINP
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
40 CONTINUE
END IF
*
* Iteration loop
*
DO 130 JIT = 1, NITMAX
*
* Loop over intervals
*
IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
*
* Begin of Parallel Version of the loop
*
DO 60 JI = KF, KL
*
* Compute N(c), the number of eigenvalues less than c
*
WORK( JI ) = D( 1 ) - C( JI )
IWORK( JI ) = 0
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
*
DO 50 J = 2, N
WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
IF( WORK( JI ).LE.PIVMIN ) THEN
IWORK( JI ) = IWORK( JI ) + 1
WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
END IF
50 CONTINUE
60 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
KLNEW = KL
DO 70 JI = KF, KL
*
* Insure that N(w) is monotone
*
IWORK( JI ) = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = C( JI )
*
ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = C( JI )
ELSE
KLNEW = KLNEW + 1
IF( KLNEW.LE.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to
* queue.
*
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = C( JI )
NAB( KLNEW, 1 ) = IWORK( JI )
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
ELSE
INFO = MMAX + 1
END IF
END IF
70 CONTINUE
IF( INFO.NE.0 )
$ RETURN
KL = KLNEW
ELSE
*
* IJOB=3: Binary search. Keep only the interval containing
* w s.t. N(w) = NVAL
*
DO 80 JI = KF, KL
IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = C( JI )
NAB( JI, 1 ) = IWORK( JI )
END IF
IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = C( JI )
NAB( JI, 2 ) = IWORK( JI )
END IF
80 CONTINUE
END IF
*
ELSE
*
* End of Parallel Version of the loop
*
* Begin of Serial Version of the loop
*
KLNEW = KL
DO 100 JI = KF, KL
*
* Compute N(w), the number of eigenvalues less than w
*
TMP1 = C( JI )
TMP2 = D( 1 ) - TMP1
ITMP1 = 0
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
*
DO 90 J = 2, N
TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
IF( TMP2.LE.PIVMIN ) THEN
ITMP1 = ITMP1 + 1
TMP2 = MIN( TMP2, -PIVMIN )
END IF
90 CONTINUE
*
IF( IJOB.LE.2 ) THEN
*
* IJOB=2: Choose all intervals containing eigenvalues.
*
* Insure that N(w) is monotone
*
ITMP1 = MIN( NAB( JI, 2 ),
$ MAX( NAB( JI, 1 ), ITMP1 ) )
*
* Update the Queue -- add intervals if both halves
* contain eigenvalues.
*
IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
*
* No eigenvalue in the upper interval:
* just use the lower interval.
*
AB( JI, 2 ) = TMP1
*
ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
*
* No eigenvalue in the lower interval:
* just use the upper interval.
*
AB( JI, 1 ) = TMP1
ELSE IF( KLNEW.LT.MMAX ) THEN
*
* Eigenvalue in both intervals -- add upper to queue.
*
KLNEW = KLNEW + 1
AB( KLNEW, 2 ) = AB( JI, 2 )
NAB( KLNEW, 2 ) = NAB( JI, 2 )
AB( KLNEW, 1 ) = TMP1
NAB( KLNEW, 1 ) = ITMP1
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
ELSE
INFO = MMAX + 1
RETURN
END IF
ELSE
*
* IJOB=3: Binary search. Keep only the interval
* containing w s.t. N(w) = NVAL
*
IF( ITMP1.LE.NVAL( JI ) ) THEN
AB( JI, 1 ) = TMP1
NAB( JI, 1 ) = ITMP1
END IF
IF( ITMP1.GE.NVAL( JI ) ) THEN
AB( JI, 2 ) = TMP1
NAB( JI, 2 ) = ITMP1
END IF
END IF
100 CONTINUE
KL = KLNEW
*
END IF
*
* Check for convergence
*
KFNEW = KF
DO 110 JI = KF, KL
TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
$ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
*
* Converged -- Swap with position KFNEW,
* then increment KFNEW
*
IF( JI.GT.KFNEW ) THEN
TMP1 = AB( JI, 1 )
TMP2 = AB( JI, 2 )
ITMP1 = NAB( JI, 1 )
ITMP2 = NAB( JI, 2 )
AB( JI, 1 ) = AB( KFNEW, 1 )
AB( JI, 2 ) = AB( KFNEW, 2 )
NAB( JI, 1 ) = NAB( KFNEW, 1 )
NAB( JI, 2 ) = NAB( KFNEW, 2 )
AB( KFNEW, 1 ) = TMP1
AB( KFNEW, 2 ) = TMP2
NAB( KFNEW, 1 ) = ITMP1
NAB( KFNEW, 2 ) = ITMP2
IF( IJOB.EQ.3 ) THEN
ITMP1 = NVAL( JI )
NVAL( JI ) = NVAL( KFNEW )
NVAL( KFNEW ) = ITMP1
END IF
END IF
KFNEW = KFNEW + 1
END IF
110 CONTINUE
KF = KFNEW
*
* Choose Midpoints
*
DO 120 JI = KF, KL
C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
120 CONTINUE
*
* If no more intervals to refine, quit.
*
IF( KF.GT.KL )
$ GO TO 140
130 CONTINUE
*
* Converged
*
140 CONTINUE
INFO = MAX( KL+1-KF, 0 )
MOUT = KL
*
RETURN
*
* End of DLAEBZ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaset.f 0000644 0000000 0000000 00000000132 14061636515 015300 x ustar 00 30 mtime=1623670093.270104019
30 atime=1623670093.270104019
30 ctime=1623670093.270104019
elk-7.2.42/src/LAPACK/dlaset.f 0000644 0025044 0025044 00000011474 14061636515 017344 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASET 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 DLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASET 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 DOUBLE PRECISION
*> The constant to which the offdiagonal elements are to be set.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION
*> The constant to which the diagonal elements are to be set.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DLASET( 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
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION 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 DLASET
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlanst.f 0000644 0000000 0000000 00000000132 14061636515 015311 x ustar 00 30 mtime=1623670093.272104017
30 atime=1623670093.272104017
30 ctime=1623670093.272104017
elk-7.2.42/src/LAPACK/dlanst.f 0000644 0025044 0025044 00000012324 14061636515 017350 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLANST 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 DLANST + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLANST 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 DLANST
*> \verbatim
*>
*> DLANST = ( 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 DLANST as described
*> above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0. When N = 0, DLANST is
*> set to zero.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION 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
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLANST( 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 ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. 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. DISNAN( SUM ) ) ANORM = SUM
SUM = ABS( E( I ) )
IF( ANORM .LT. SUM .OR. DISNAN( 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. DISNAN( 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. DISNAN( 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 DLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL DLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
DLANST = ANORM
RETURN
*
* End of DLANST
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaev2.f 0000644 0000000 0000000 00000000132 14061636515 015201 x ustar 00 30 mtime=1623670093.274104015
30 atime=1623670093.273104016
30 ctime=1623670093.274104015
elk-7.2.42/src/LAPACK/dlaev2.f 0000644 0025044 0025044 00000014072 14061636515 017242 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAEV2 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 DLAEV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAEV2 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 DOUBLE PRECISION
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION
*> 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 DOUBLE PRECISION
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*> RT1 is DOUBLE PRECISION
*> The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*> RT2 is DOUBLE PRECISION
*> The eigenvalue of smaller absolute value.
*> \endverbatim
*>
*> \param[out] CS1
*> \verbatim
*> CS1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] SN1
*> \verbatim
*> SN1 is DOUBLE PRECISION
*> 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 DLAEV2( 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 ..
DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
INTEGER SGN1, SGN2
DOUBLE PRECISION 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 DLAEV2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasr.f 0000644 0000000 0000000 00000000132 14061636515 015131 x ustar 00 30 mtime=1623670093.276104013
30 atime=1623670093.275104014
30 ctime=1623670093.276104013
elk-7.2.42/src/LAPACK/dlasr.f 0000644 0025044 0025044 00000035306 14061636515 017175 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASR 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 DLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, PIVOT, SIDE
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASR 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 DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The cosines c(k) of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The sines s(k) of the plane rotations. The 2-by-2 plane
*> rotation part of the matrix P(k), R(k), has the form
*> R(k) = ( c(k) s(k) )
*> ( -s(k) c(k) ).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The M-by-N matrix A. On exit, A is overwritten by P*A if
*> SIDE = 'L' or by A*P**T if SIDE = 'R'.
*> \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 DLASR( 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 ..
DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION 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( 'DLASR ', 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 DLASR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlae2.f 0000644 0000000 0000000 00000000132 14061636515 015013 x ustar 00 30 mtime=1623670093.277104012
30 atime=1623670093.277104012
30 ctime=1623670093.277104012
elk-7.2.42/src/LAPACK/dlae2.f 0000644 0025044 0025044 00000011311 14061636515 017045 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAE2 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 DLAE2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION A, B, C, RT1, RT2
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAE2 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 DOUBLE PRECISION
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION
*> The (1,2) and (2,1) elements of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*> RT1 is DOUBLE PRECISION
*> The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*> RT2 is DOUBLE PRECISION
*> 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 DLAE2( 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 ..
DOUBLE PRECISION A, B, C, RT1, RT2
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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 DLAE2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlapy2.f 0000644 0000000 0000000 00000000132 14061636515 015217 x ustar 00 30 mtime=1623670093.279104011
30 atime=1623670093.279104011
30 ctime=1623670093.279104011
elk-7.2.42/src/LAPACK/dlapy2.f 0000644 0025044 0025044 00000005466 14061636515 017267 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAPY2 returns sqrt(x2+y2).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> 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
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY2( 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 ..
DOUBLE PRECISION X, Y
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, Z
LOGICAL X_IS_NAN, Y_IS_NAN
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
X_IS_NAN = DISNAN( X )
Y_IS_NAN = DISNAN( Y )
IF ( X_IS_NAN ) DLAPY2 = X
IF ( Y_IS_NAN ) DLAPY2 = 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
DLAPY2 = W
ELSE
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
END IF
RETURN
*
* End of DLAPY2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlartg.f 0000644 0000000 0000000 00000000132 14061636515 015301 x ustar 00 30 mtime=1623670093.281104009
30 atime=1623670093.281104009
30 ctime=1623670093.281104009
elk-7.2.42/src/LAPACK/dlartg.f 0000644 0025044 0025044 00000012613 14061636515 017341 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARTG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CS, F, G, R, SN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARTG generate a plane rotation so that
*>
*> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
*> [ -SN CS ] [ G ] [ 0 ]
*>
*> This is a slower, more accurate version of the BLAS1 routine DROTG,
*> with the following other differences:
*> F and G are unchanged on return.
*> If G=0, then CS=1 and SN=0.
*> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
*> floating point operations (saves work in DBDSQR when
*> there are zeros on the diagonal).
*>
*> If F exceeds G in magnitude, CS will be positive.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is DOUBLE PRECISION
*> The first component of vector to be rotated.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is DOUBLE PRECISION
*> The second component of vector to be rotated.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is DOUBLE PRECISION
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is DOUBLE PRECISION
*> The sine of the rotation.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is DOUBLE PRECISION
*> The nonzero component of the rotated vector.
*>
*> This version has a few statements commented out for thread safety
*> (machine parameters are computed on each entry). 10 feb 03, SJH.
*> \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 DLARTG( F, G, CS, SN, R )
*
* -- 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 ..
DOUBLE PRECISION CS, F, G, R, SN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, SQRT
* ..
* .. Save statement ..
* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
* DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
* IF( FIRST ) THEN
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
* FIRST = .FALSE.
* END IF
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
F1 = F
G1 = G
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 ) THEN
COUNT = 0
10 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMN2
G1 = G1*SAFMN2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 20 I = 1, COUNT
R = R*SAFMX2
20 CONTINUE
ELSE IF( SCALE.LE.SAFMN2 ) THEN
COUNT = 0
30 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMX2
G1 = G1*SAFMX2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.LE.SAFMN2 )
$ GO TO 30
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 40 I = 1, COUNT
R = R*SAFMN2
40 CONTINUE
ELSE
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
END IF
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
CS = -CS
SN = -SN
R = -R
END IF
END IF
RETURN
*
* End of DLARTG
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasrt.f 0000644 0000000 0000000 00000000132 14061636515 015315 x ustar 00 30 mtime=1623670093.283104007
30 atime=1623670093.282104008
30 ctime=1623670093.283104007
elk-7.2.42/src/LAPACK/dlasrt.f 0000644 0025044 0025044 00000017314 14061636515 017360 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASRT sorts numbers in increasing or decreasing order.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASRT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASRT( ID, N, D, INFO )
*
* .. Scalar Arguments ..
* CHARACTER ID
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLASRT( 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 ..
DOUBLE PRECISION D( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
DOUBLE PRECISION 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( 'DLASRT', -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 DLASRT
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlacpy.f 0000644 0000000 0000000 00000000132 14061636515 015300 x ustar 00 30 mtime=1623670093.285104005
30 atime=1623670093.284104006
30 ctime=1623670093.285104005
elk-7.2.42/src/LAPACK/dlacpy.f 0000644 0025044 0025044 00000010001 14061636515 017325 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLACPY 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 DLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLACPY 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLACPY( 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 ..
DOUBLE PRECISION 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 DLACPY
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dstein.f 0000644 0000000 0000000 00000000132 14061636515 015312 x ustar 00 30 mtime=1623670093.286104004
30 atime=1623670093.286104004
30 ctime=1623670093.286104004
elk-7.2.42/src/LAPACK/dstein.f 0000644 0025044 0025044 00000032141 14061636515 017350 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSTEIN
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEIN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
* IWORK, IFAIL, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDZ, M, N
* ..
* .. Array Arguments ..
* INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
* $ IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSTEIN computes the eigenvectors of a real symmetric tridiagonal
*> matrix T corresponding to specified eigenvalues, using inverse
*> iteration.
*>
*> The maximum number of iterations allowed for each eigenvector is
*> specified by an internal parameter MAXITS (currently set to 5).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The n diagonal elements of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The (n-1) subdiagonal elements of the tridiagonal matrix
*> T, in elements 1 to N-1.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of eigenvectors to be found. 0 <= M <= N.
*> \endverbatim
*>
*> \param[in] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> The first M elements of W contain the eigenvalues for
*> which eigenvectors are to be computed. The eigenvalues
*> should be grouped by split-off block and ordered from
*> smallest to largest within the block. ( The output array
*> W from DSTEBZ with ORDER = 'B' is expected here. )
*> \endverbatim
*>
*> \param[in] IBLOCK
*> \verbatim
*> IBLOCK is INTEGER array, dimension (N)
*> The submatrix indices associated with the corresponding
*> eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
*> the first submatrix from the top, =2 if W(i) belongs to
*> the second submatrix, etc. ( The output array IBLOCK
*> from DSTEBZ is expected here. )
*> \endverbatim
*>
*> \param[in] ISPLIT
*> \verbatim
*> ISPLIT is INTEGER array, dimension (N)
*> The splitting points, at which T breaks up into submatrices.
*> The first submatrix consists of rows/columns 1 to
*> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
*> through ISPLIT( 2 ), etc.
*> ( The output array ISPLIT from DSTEBZ is expected here. )
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ, M)
*> The computed eigenvectors. The eigenvector associated
*> with the eigenvalue W(i) is stored in the i-th column of
*> Z. Any vector which fails to converge is set to its current
*> iterate after MAXITS iterations.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (5*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] IFAIL
*> \verbatim
*> IFAIL is INTEGER array, dimension (M)
*> On normal exit, all elements of IFAIL are zero.
*> If one or more eigenvectors fail to converge after
*> MAXITS iterations, then their indices are stored in
*> array IFAIL.
*> \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, then i eigenvectors failed to converge
*> in MAXITS iterations. Their indices are stored in
*> array IFAIL.
*> \endverbatim
*
*> \par Internal Parameters:
* =========================
*>
*> \verbatim
*> MAXITS INTEGER, default = 5
*> The maximum number of iterations performed.
*>
*> EXTRA INTEGER, default = 2
*> The number of iterations performed after norm growth
*> criterion is satisfied, should be at least 1.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
$ IWORK, IFAIL, 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, LDZ, M, N
* ..
* .. Array Arguments ..
INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
$ IWORK( * )
DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
$ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
INTEGER MAXITS, EXTRA
PARAMETER ( MAXITS = 5, EXTRA = 2 )
* ..
* .. Local Scalars ..
INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
$ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
$ JBLK, JMAX, NBLK, NRMCHK
DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
$ SCL, SEP, TOL, XJ, XJM, ZTR
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 )
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DDOT, DLAMCH, DNRM2
EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
$ XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
DO 10 I = 1, M
IFAIL( I ) = 0
10 CONTINUE
*
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
INFO = -4
ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE
DO 20 J = 2, M
IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
INFO = -6
GO TO 30
END IF
IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
$ THEN
INFO = -5
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSTEIN', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
EPS = DLAMCH( 'Precision' )
*
* Initialize seed for random number generator DLARNV.
*
DO 40 I = 1, 4
ISEED( I ) = 1
40 CONTINUE
*
* Initialize pointers.
*
INDRV1 = 0
INDRV2 = INDRV1 + N
INDRV3 = INDRV2 + N
INDRV4 = INDRV3 + N
INDRV5 = INDRV4 + N
*
* Compute eigenvectors of matrix blocks.
*
J1 = 1
DO 160 NBLK = 1, IBLOCK( M )
*
* Find starting and ending indices of block nblk.
*
IF( NBLK.EQ.1 ) THEN
B1 = 1
ELSE
B1 = ISPLIT( NBLK-1 ) + 1
END IF
BN = ISPLIT( NBLK )
BLKSIZ = BN - B1 + 1
IF( BLKSIZ.EQ.1 )
$ GO TO 60
GPIND = J1
*
* Compute reorthogonalization criterion and stopping criterion.
*
ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
DO 50 I = B1 + 1, BN - 1
ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
$ ABS( E( I ) ) )
50 CONTINUE
ORTOL = ODM3*ONENRM
*
DTPCRT = SQRT( ODM1 / BLKSIZ )
*
* Loop through eigenvalues of block nblk.
*
60 CONTINUE
JBLK = 0
DO 150 J = J1, M
IF( IBLOCK( J ).NE.NBLK ) THEN
J1 = J
GO TO 160
END IF
JBLK = JBLK + 1
XJ = W( J )
*
* Skip all the work if the block size is one.
*
IF( BLKSIZ.EQ.1 ) THEN
WORK( INDRV1+1 ) = ONE
GO TO 120
END IF
*
* If eigenvalues j and j-1 are too close, add a relatively
* small perturbation.
*
IF( JBLK.GT.1 ) THEN
EPS1 = ABS( EPS*XJ )
PERTOL = TEN*EPS1
SEP = XJ - XJM
IF( SEP.LT.PERTOL )
$ XJ = XJM + PERTOL
END IF
*
ITS = 0
NRMCHK = 0
*
* Get random starting vector.
*
CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
*
* Copy the matrix T so it won't be destroyed in factorization.
*
CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
*
* Compute LU factors with partial pivoting ( PT = LU )
*
TOL = ZERO
CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
$ IINFO )
*
* Update iteration count.
*
70 CONTINUE
ITS = ITS + 1
IF( ITS.GT.MAXITS )
$ GO TO 100
*
* Normalize and scale the righthand side vector Pb.
*
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
SCL = BLKSIZ*ONENRM*MAX( EPS,
$ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
$ ABS( WORK( INDRV1+JMAX ) )
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
*
* Solve the system LU = Pb.
*
CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
$ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
$ WORK( INDRV1+1 ), TOL, IINFO )
*
* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
* close enough.
*
IF( JBLK.EQ.1 )
$ GO TO 90
IF( ABS( XJ-XJM ).GT.ORTOL )
$ GPIND = J
IF( GPIND.NE.J ) THEN
DO 80 I = GPIND, J - 1
ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
$ 1 )
CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
$ WORK( INDRV1+1 ), 1 )
80 CONTINUE
END IF
*
* Check the infinity norm of the iterate.
*
90 CONTINUE
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
NRM = ABS( WORK( INDRV1+JMAX ) )
*
* Continue for additional iterations after norm reaches
* stopping criterion.
*
IF( NRM.LT.DTPCRT )
$ GO TO 70
NRMCHK = NRMCHK + 1
IF( NRMCHK.LT.EXTRA+1 )
$ GO TO 70
*
GO TO 110
*
* If stopping criterion was not satisfied, update info and
* store eigenvector number in array ifail.
*
100 CONTINUE
INFO = INFO + 1
IFAIL( INFO ) = J
*
* Accept iterate as jth eigenvector.
*
110 CONTINUE
SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
IF( WORK( INDRV1+JMAX ).LT.ZERO )
$ SCL = -SCL
CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
120 CONTINUE
DO 130 I = 1, N
Z( I, J ) = ZERO
130 CONTINUE
DO 140 I = 1, BLKSIZ
Z( B1+I-1, J ) = WORK( INDRV1+I )
140 CONTINUE
*
* Save the shift to check eigenvalue spacing at next
* iteration.
*
XJM = XJ
*
150 CONTINUE
160 CONTINUE
*
RETURN
*
* End of DSTEIN
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dormtr.f 0000644 0000000 0000000 00000000132 14061636515 015333 x ustar 00 30 mtime=1623670093.288104002
30 atime=1623670093.288104002
30 ctime=1623670093.288104002
elk-7.2.42/src/LAPACK/dormtr.f 0000644 0025044 0025044 00000021134 14061636515 017371 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORMTR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMTR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMTR( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORMTR overwrites the general real M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*>
*> where Q is a real orthogonal 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 DSYTRD:
*>
*> 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**T from the Left;
*> = 'R': apply Q or Q**T from the Right.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A contains elementary reflectors
*> from DSYTRD;
*> = 'L': Lower triangle of A contains elementary reflectors
*> from DSYTRD.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'T': Transpose, apply Q**T.
*> \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 DOUBLE PRECISION array, dimension
*> (LDA,M) if SIDE = 'L'
*> (LDA,N) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by DSYTRD.
*> \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 DOUBLE PRECISION 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 DSYTRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS, UPLO
INTEGER INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, UPPER
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DORMQL, DORMQR, 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 = N
ELSE
NQ = N
NW = 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, 'T' ) )
$ 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.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
IF( UPPER ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
ELSE
IF( LEFT ) THEN
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
$ -1 )
ELSE
NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
$ -1 )
END IF
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMTR', -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 DSYTRD with UPLO = 'U'
*
CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
$ LDC, WORK, LWORK, IINFO )
ELSE
*
* Q was determined by a call to DSYTRD with UPLO = 'L'
*
IF( LEFT ) THEN
I1 = 2
I2 = 1
ELSE
I1 = 1
I2 = 2
END IF
CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
$ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMTR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsygs2.f 0000644 0000000 0000000 00000000121 14061636515 015235 x ustar 00 27 mtime=1623670093.290104
27 atime=1623670093.290104
27 ctime=1623670093.290104
elk-7.2.42/src/LAPACK/dsygs2.f 0000644 0025044 0025044 00000021237 14061636515 017301 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYGS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYGS2 reduces a real symmetric-definite generalized eigenproblem
*> to standard form.
*>
*> If ITYPE = 1, the problem is A*x = lambda*B*x,
*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
*>
*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L.
*>
*> B must have been previously factorized as U**T *U or L*L**T by DPOTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
*> = 2 or 3: compute U*A*U**T or L**T *A*L.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored, and how B has been factorized.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n by n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n by n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the transformed matrix, stored in the
*> same format as A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
*> The triangular factor from the Cholesky factorization of B,
*> as returned by DPOTRF.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYcomputational
*
* =====================================================================
SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, 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 UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, HALF
PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K
DOUBLE PRECISION AKK, BKK, CT
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYGS2', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U**T)*A*inv(U)
*
DO 10 K = 1, N
*
* Update the upper triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
CT = -HALF*AKK
CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
$ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L**T)
*
DO 20 K = 1, N
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
CT = -HALF*AKK
CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
$ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U**T
*
DO 30 K = 1, N
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
$ LDB, A( 1, K ), 1 )
CT = HALF*AKK
CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
$ A, LDA )
CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL DSCAL( K-1, BKK, A( 1, K ), 1 )
A( K, K ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L**T *A*L
*
DO 40 K = 1, N
*
* Update the lower triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
$ A( K, 1 ), LDA )
CT = HALF*AKK
CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
$ LDB, A, LDA )
CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL DSCAL( K-1, BKK, A( K, 1 ), LDA )
A( K, K ) = AKK*BKK**2
40 CONTINUE
END IF
END IF
RETURN
*
* End of DSYGS2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlatrd.f 0000644 0000000 0000000 00000000132 14061636515 015276 x ustar 00 30 mtime=1623670093.292103998
30 atime=1623670093.292103998
30 ctime=1623670093.292103998
elk-7.2.42/src/LAPACK/dlatrd.f 0000644 0025044 0025044 00000026560 14061636515 017344 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLATRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLATRD reduces NB rows and columns of a real symmetric matrix A to
*> symmetric tridiagonal form by an orthogonal similarity
*> transformation Q**T * 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', DLATRD reduces the last NB rows and columns of a
*> matrix, of which the upper triangle is supplied;
*> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
*> matrix, of which the lower triangle is supplied.
*>
*> This is an auxiliary routine called by DSYTRD.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \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 DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit:
*> if 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 orthogonal 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 orthogonal 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 >= (1,N).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
*> elements of the last NB columns of the reduced matrix;
*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
*> the first NB columns of the reduced matrix.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDW,NB)
*> The n-by-nb matrix W required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERauxiliary
*
*> \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**T
*>
*> where tau is a real scalar, and v is a real 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**T
*>
*> where tau is a real scalar, and v is a real 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 symmetric rank-2k update of the form:
*> A := A - V*W**T - W*V**T.
*>
*> 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 DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- 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, LDW, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, HALF
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IW
DOUBLE PRECISION ALPHA
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = A( I-1, I )
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
$ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
CALL DGEMV( '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 DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL DAXPY( 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)
*
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = A( I+1, I )
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of DLATRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dsytd2.f 0000644 0000000 0000000 00000000132 14061636515 015235 x ustar 00 30 mtime=1623670093.294103996
30 atime=1623670093.294103996
30 ctime=1623670093.294103996
elk-7.2.42/src/LAPACK/dsytd2.f 0000644 0025044 0025044 00000023172 14061636515 017277 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
*> form T by an orthogonal similarity transformation: Q**T * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> symmetric matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the symmetric matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if 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 orthogonal
*> 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 orthogonal matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleSYcomputational
*
*> \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**T
*>
*> where tau is a real scalar, and v is a real 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**T
*>
*> where tau is a real scalar, and v is a real 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 DSYTD2( UPLO, N, A, LDA, D, E, 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 ..
CHARACTER UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO, HALF
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
$ HALF = 1.0D0 / 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
DOUBLE PRECISION ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DDOT
EXTERNAL LSAME, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DSYTD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v**T
* to annihilate A(1:i-1,i+1)
*
CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
E( I ) = A( I, I+1 )
*
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 DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x**T * v) * v
*
ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**T - w * v**T
*
CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
A( I, I+1 ) = E( I )
END IF
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v**T
* to annihilate A(i+2:n,i)
*
CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
$ TAUI )
E( I ) = A( I+1, I )
*
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 DSYMV( 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**T * v) * v
*
ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**T - w * v**T
*
CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
A( I+1, I ) = E( I )
END IF
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of DSYTD2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dtrti2.f 0000644 0000000 0000000 00000000132 14061636515 015234 x ustar 00 30 mtime=1623670093.296103995
30 atime=1623670093.296103995
30 ctime=1623670093.296103995
elk-7.2.42/src/LAPACK/dtrti2.f 0000644 0025044 0025044 00000013423 14061636515 017274 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTRTI2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRTI2 computes the inverse of a real upper or lower triangular
*> matrix.
*>
*> This is the Level 2 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower triangular.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A is unit triangular.
*> = 'N': Non-unit triangular
*> = 'U': Unit triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the triangular matrix A. If UPLO = 'U', the
*> leading n by n upper triangular part of the array A contains
*> the upper triangular matrix, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n by n lower triangular part of the array A contains
*> the lower triangular matrix, and the strictly upper
*> triangular part of A is not referenced. If DIAG = 'U', the
*> diagonal elements of A are also not referenced and are
*> assumed to be 1.
*>
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DTRMV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of DTRTI2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq1.f 0000644 0000000 0000000 00000000132 14061636515 015211 x ustar 00 30 mtime=1623670093.298103993
30 atime=1623670093.298103993
30 ctime=1623670093.298103993
elk-7.2.42/src/LAPACK/dlasq1.f 0000644 0025044 0025044 00000015023 14061636515 017247 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ1 computes the singular values of a real N-by-N bidiagonal
*> matrix with diagonal D and off-diagonal E. The singular values
*> are computed to high relative accuracy, in the absence of
*> denormalization, underflow and overflow. The algorithm was first
*> presented in
*>
*> "Accurate singular values and differential qd algorithms" by K. V.
*> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
*> 1994,
*>
*> and the present implementation is described in "An implementation of
*> the dqds Algorithm (Positive Case)", LAPACK Working Note.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows and columns in the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, D contains the diagonal elements of the
*> bidiagonal matrix whose SVD is desired. On normal exit,
*> D contains the singular values in decreasing order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N)
*> On entry, elements E(1:N-1) contain the off-diagonal elements
*> of the bidiagonal matrix whose SVD is desired.
*> On exit, E is overwritten.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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: the algorithm failed
*> = 1, a split was marked by a positive value in E
*> = 2, current block of Z not diagonalized after 100*N
*> iterations (in inner while loop) On exit D and E
*> represent a matrix with the same singular values
*> which the calling subroutine could use to finish the
*> computation, or even feed back into DLASQ1
*> = 3, termination criterion of outer while loop not met
*> (program created more than N unreduced blocks)
*> \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 DLASQ1( N, D, E, 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 ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IINFO
DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLASQ1', -INFO )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
D( 1 ) = ABS( D( 1 ) )
RETURN
ELSE IF( N.EQ.2 ) THEN
CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
D( 1 ) = SIGMX
D( 2 ) = SIGMN
RETURN
END IF
*
* Estimate the largest singular value.
*
SIGMX = ZERO
DO 10 I = 1, N - 1
D( I ) = ABS( D( I ) )
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
10 CONTINUE
D( N ) = ABS( D( N ) )
*
* Early return if SIGMX is zero (matrix is already diagonal).
*
IF( SIGMX.EQ.ZERO ) THEN
CALL DLASRT( 'D', N, D, IINFO )
RETURN
END IF
*
DO 20 I = 1, N
SIGMX = MAX( SIGMX, D( I ) )
20 CONTINUE
*
* Copy D and E into WORK (in the Z format) and scale (squaring the
* input data makes scaling by a power of the radix pointless).
*
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
SCALE = SQRT( EPS / SAFMIN )
CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
$ IINFO )
*
* Compute the q's and e's.
*
DO 30 I = 1, 2*N - 1
WORK( I ) = WORK( I )**2
30 CONTINUE
WORK( 2*N ) = ZERO
*
CALL DLASQ2( N, WORK, INFO )
*
IF( INFO.EQ.0 ) THEN
DO 40 I = 1, N
D( I ) = SQRT( WORK( I ) )
40 CONTINUE
CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
ELSE IF( INFO.EQ.2 ) THEN
*
* Maximum number of iterations exceeded. Move data from WORK
* into D and E so the calling subroutine can try to finish
*
DO I = 1, N
D( I ) = SQRT( WORK( 2*I-1 ) )
E( I ) = SQRT( WORK( 2*I ) )
END DO
CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO )
END IF
*
RETURN
*
* End of DLASQ1
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlasr.f 0000644 0000000 0000000 00000000132 14061636515 015157 x ustar 00 30 mtime=1623670093.300103991
30 atime=1623670093.300103991
30 ctime=1623670093.300103991
elk-7.2.42/src/LAPACK/zlasr.f 0000644 0025044 0025044 00000035433 14061636515 017224 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, PIVOT, SIDE
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( * ), S( * )
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASR applies a sequence of real plane rotations to a complex matrix
*> A, from either the left or the right.
*>
*> When SIDE = 'L', the transformation takes the form
*>
*> A := P*A
*>
*> and when SIDE = 'R', the transformation takes the form
*>
*> A := A*P**T
*>
*> where P is an orthogonal matrix consisting of a sequence of z plane
*> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
*> and P**T is the transpose of P.
*>
*> When DIRECT = 'F' (Forward sequence), then
*>
*> P = P(z-1) * ... * P(2) * P(1)
*>
*> and when DIRECT = 'B' (Backward sequence), then
*>
*> P = P(1) * P(2) * ... * P(z-1)
*>
*> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
*>
*> R(k) = ( c(k) s(k) )
*> = ( -s(k) c(k) ).
*>
*> When PIVOT = 'V' (Variable pivot), the rotation is performed
*> for the plane (k,k+1), i.e., P(k) has the form
*>
*> P(k) = ( 1 )
*> ( ... )
*> ( 1 )
*> ( c(k) s(k) )
*> ( -s(k) c(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*>
*> where R(k) appears as a rank-2 modification to the identity matrix in
*> rows and columns k and k+1.
*>
*> When PIVOT = 'T' (Top pivot), the rotation is performed for the
*> plane (1,k+1), so P(k) has the form
*>
*> P(k) = ( c(k) s(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*> ( -s(k) c(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*>
*> where R(k) appears in rows and columns 1 and k+1.
*>
*> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
*> performed for the plane (k,z), giving P(k) the form
*>
*> P(k) = ( 1 )
*> ( ... )
*> ( 1 )
*> ( c(k) s(k) )
*> ( 1 )
*> ( ... )
*> ( 1 )
*> ( -s(k) c(k) )
*>
*> where R(k) appears in rows and columns k and z. The rotations are
*> performed without ever forming P(k) explicitly.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> Specifies whether the plane rotation matrix P is applied to
*> A on the left or the right.
*> = 'L': Left, compute A := P*A
*> = 'R': Right, compute A:= A*P**T
*> \endverbatim
*>
*> \param[in] PIVOT
*> \verbatim
*> PIVOT is CHARACTER*1
*> Specifies the plane for which P(k) is a plane rotation
*> matrix.
*> = 'V': Variable pivot, the plane (k,k+1)
*> = 'T': Top pivot, the plane (1,k+1)
*> = 'B': Bottom pivot, the plane (k,z)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies whether P is a forward or backward sequence of
*> plane rotations.
*> = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
*> = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. If m <= 1, an immediate
*> return is effected.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. If n <= 1, an
*> immediate return is effected.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The cosines c(k) of the plane rotations.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> The sines s(k) of the plane rotations. The 2-by-2 plane
*> rotation part of the matrix P(k), R(k), has the form
*> R(k) = ( c(k) s(k) )
*> ( -s(k) c(k) ).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The M-by-N matrix A. On exit, A is overwritten by P*A if
*> SIDE = 'R' or by A*P**T if SIDE = 'L'.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASR( 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 ..
DOUBLE PRECISION C( * ), S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP
COMPLEX*16 TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P**T
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZLASR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasv2.f 0000644 0000000 0000000 00000000132 14061636515 015217 x ustar 00 30 mtime=1623670093.302103989
30 atime=1623670093.302103989
30 ctime=1623670093.302103989
elk-7.2.42/src/LAPACK/dlasv2.f 0000644 0025044 0025044 00000020451 14061636515 017256 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASV2 computes the singular value decomposition of a 2-by-2
*> triangular matrix
*> [ F G ]
*> [ 0 H ].
*> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
*> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
*> right singular vectors for abs(SSMAX), giving the decomposition
*>
*> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
*> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is DOUBLE PRECISION
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is DOUBLE PRECISION
*> The (1,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*> H is DOUBLE PRECISION
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] SSMIN
*> \verbatim
*> SSMIN is DOUBLE PRECISION
*> abs(SSMIN) is the smaller singular value.
*> \endverbatim
*>
*> \param[out] SSMAX
*> \verbatim
*> SSMAX is DOUBLE PRECISION
*> abs(SSMAX) is the larger singular value.
*> \endverbatim
*>
*> \param[out] SNL
*> \verbatim
*> SNL is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] CSL
*> \verbatim
*> CSL is DOUBLE PRECISION
*> The vector (CSL, SNL) is a unit left singular vector for the
*> singular value abs(SSMAX).
*> \endverbatim
*>
*> \param[out] SNR
*> \verbatim
*> SNR is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] CSR
*> \verbatim
*> CSR is DOUBLE PRECISION
*> The vector (CSR, SNR) is a unit right singular vector for the
*> singular value abs(SSMAX).
*> \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
*>
*> Any input parameter may be aliased with any output parameter.
*>
*> Barring over/underflow and assuming a guard digit in subtraction, all
*> output quantities are correct to within a few units in the last
*> place (ulps).
*>
*> In IEEE arithmetic, the code works correctly if one matrix element is
*> infinite.
*>
*> Overflow will not occur unless the largest singular value itself
*> overflows or is within a few ulps of overflow. (On machines with
*> partial overflow, like the Cray, overflow may occur if the largest
*> singular value is within a factor of 2 of overflow.)
*>
*> Underflow is harmless if underflow is gradual. Otherwise, results
*> may correspond to a matrix modified by perturbations of size near
*> the underflow threshold.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* -- 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 ..
DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION FOUR
PARAMETER ( FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
LOGICAL GASMAL, SWAP
INTEGER PMAX
DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
$ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
FT = F
FA = ABS( FT )
HT = H
HA = ABS( H )
*
* PMAX points to the maximum absolute element of matrix
* PMAX = 1 if F largest in absolute values
* PMAX = 2 if G largest in absolute values
* PMAX = 3 if H largest in absolute values
*
PMAX = 1
SWAP = ( HA.GT.FA )
IF( SWAP ) THEN
PMAX = 3
TEMP = FT
FT = HT
HT = TEMP
TEMP = FA
FA = HA
HA = TEMP
*
* Now FA .ge. HA
*
END IF
GT = G
GA = ABS( GT )
IF( GA.EQ.ZERO ) THEN
*
* Diagonal matrix
*
SSMIN = HA
SSMAX = FA
CLT = ONE
CRT = ONE
SLT = ZERO
SRT = ZERO
ELSE
GASMAL = .TRUE.
IF( GA.GT.FA ) THEN
PMAX = 2
IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
*
* Case of very large GA
*
GASMAL = .FALSE.
SSMAX = GA
IF( HA.GT.ONE ) THEN
SSMIN = FA / ( GA / HA )
ELSE
SSMIN = ( FA / GA )*HA
END IF
CLT = ONE
SLT = HT / GT
SRT = ONE
CRT = FT / GT
END IF
END IF
IF( GASMAL ) THEN
*
* Normal case
*
D = FA - HA
IF( D.EQ.FA ) THEN
*
* Copes with infinite F or H
*
L = ONE
ELSE
L = D / FA
END IF
*
* Note that 0 .le. L .le. 1
*
M = GT / FT
*
* Note that abs(M) .le. 1/macheps
*
T = TWO - L
*
* Note that T .ge. 1
*
MM = M*M
TT = T*T
S = SQRT( TT+MM )
*
* Note that 1 .le. S .le. 1 + 1/macheps
*
IF( L.EQ.ZERO ) THEN
R = ABS( M )
ELSE
R = SQRT( L*L+MM )
END IF
*
* Note that 0 .le. R .le. 1 + 1/macheps
*
A = HALF*( S+R )
*
* Note that 1 .le. A .le. 1 + abs(M)
*
SSMIN = HA / A
SSMAX = FA*A
IF( MM.EQ.ZERO ) THEN
*
* Note that M is very tiny
*
IF( L.EQ.ZERO ) THEN
T = SIGN( TWO, FT )*SIGN( ONE, GT )
ELSE
T = GT / SIGN( D, FT ) + M / T
END IF
ELSE
T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
END IF
L = SQRT( T*T+FOUR )
CRT = TWO / L
SRT = T / L
CLT = ( CRT+SRT*M ) / A
SLT = ( HT / FT )*SRT / A
END IF
END IF
IF( SWAP ) THEN
CSL = SRT
SNL = CRT
CSR = SLT
SNR = CLT
ELSE
CSL = CLT
SNL = SLT
CSR = CRT
SNR = SRT
END IF
*
* Correct signs of SSMAX and SSMIN
*
IF( PMAX.EQ.1 )
$ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
IF( PMAX.EQ.2 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
IF( PMAX.EQ.3 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
SSMAX = SIGN( SSMAX, TSIGN )
SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
RETURN
*
* End of DLASV2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlas2.f 0000644 0000000 0000000 00000000132 14061636515 015031 x ustar 00 30 mtime=1623670093.304103987
30 atime=1623670093.303103988
30 ctime=1623670093.304103987
elk-7.2.42/src/LAPACK/dlas2.f 0000644 0025044 0025044 00000011753 14061636515 017075 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION F, G, H, SSMAX, SSMIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAS2 computes the singular values of the 2-by-2 matrix
*> [ F G ]
*> [ 0 H ].
*> On return, SSMIN is the smaller singular value and SSMAX is the
*> larger singular value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is DOUBLE PRECISION
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is DOUBLE PRECISION
*> The (1,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*> H is DOUBLE PRECISION
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] SSMIN
*> \verbatim
*> SSMIN is DOUBLE PRECISION
*> The smaller singular value.
*> \endverbatim
*>
*> \param[out] SSMAX
*> \verbatim
*> SSMAX is DOUBLE PRECISION
*> The larger singular 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
*>
*> Barring over/underflow, all output quantities are correct to within
*> a few units in the last place (ulps), even in the absence of a guard
*> digit in addition/subtraction.
*>
*> In IEEE arithmetic, the code works correctly if one matrix element is
*> infinite.
*>
*> Overflow will not occur unless the largest singular value itself
*> overflows, or is within a few ulps of overflow. (On machines with
*> partial overflow, like the Cray, overflow may occur if the largest
*> singular value is within a factor of 2 of overflow.)
*>
*> Underflow is harmless if underflow is gradual. Otherwise, results
*> may correspond to a matrix modified by perturbations of size near
*> the underflow threshold.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
*
* -- 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 ..
DOUBLE PRECISION F, G, H, SSMAX, SSMIN
* ..
*
* ====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
FA = ABS( F )
GA = ABS( G )
HA = ABS( H )
FHMN = MIN( FA, HA )
FHMX = MAX( FA, HA )
IF( FHMN.EQ.ZERO ) THEN
SSMIN = ZERO
IF( FHMX.EQ.ZERO ) THEN
SSMAX = GA
ELSE
SSMAX = MAX( FHMX, GA )*SQRT( ONE+
$ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
END IF
ELSE
IF( GA.LT.FHMX ) THEN
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
AU = ( GA / FHMX )**2
C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
SSMIN = FHMN*C
SSMAX = FHMX / C
ELSE
AU = FHMX / GA
IF( AU.EQ.ZERO ) THEN
*
* Avoid possible harmful underflow if exponent range
* asymmetric (true SSMIN may not underflow even if
* AU underflows)
*
SSMIN = ( FHMN*FHMX ) / GA
SSMAX = GA
ELSE
AS = ONE + FHMN / FHMX
AT = ( FHMX-FHMN ) / FHMX
C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
$ SQRT( ONE+( AT*AU )**2 ) )
SSMIN = ( FHMN*C )*AU
SSMIN = SSMIN + SSMIN
SSMAX = GA / ( C+C )
END IF
END IF
END IF
RETURN
*
* End of DLAS2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlabrd.f 0000644 0000000 0000000 00000000132 14061636515 015302 x ustar 00 30 mtime=1623670093.306103985
30 atime=1623670093.305103986
30 ctime=1623670093.306103985
elk-7.2.42/src/LAPACK/zlabrd.f 0000644 0025044 0025044 00000035767 14061636515 017361 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLABRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
* LDY )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
* $ Y( LDY, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLABRD reduces the first NB rows and columns of a complex general
*> m by n matrix A to upper or lower real bidiagonal form by a unitary
*> transformation Q**H * A * P, and returns the matrices X and Y which
*> are needed to apply the transformation to the unreduced part of A.
*>
*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
*> bidiagonal form.
*>
*> This is an auxiliary routine called by ZGEBRD
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of leading rows and columns of A to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n general matrix to be reduced.
*> On exit, the first NB rows and columns of the matrix are
*> overwritten; the rest of the array is unchanged.
*> If m >= n, elements on and below the diagonal in the first NB
*> columns, with the array TAUQ, represent the unitary
*> matrix Q as a product of elementary reflectors; and
*> elements above the diagonal in the first NB rows, with the
*> array TAUP, represent the unitary matrix P as a product
*> of elementary reflectors.
*> If m < n, elements below the diagonal in the first NB
*> columns, with the array TAUQ, represent the unitary
*> matrix Q as a product of elementary reflectors, and
*> elements on and above the diagonal in the first NB rows,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (NB)
*> The diagonal elements of the first NB rows and columns of
*> the reduced matrix. D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (NB)
*> The off-diagonal elements of the first NB rows and columns of
*> the reduced matrix.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (LDX,NB)
*> The m-by-nb matrix X required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*> LDX is INTEGER
*> The leading dimension of the array X. LDX >= max(1,M).
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (LDY,NB)
*> The n-by-nb matrix Y required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*> LDY is INTEGER
*> The leading dimension of the array Y. LDY >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors.
*>
*> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
*> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The elements of the vectors v and u together form the m-by-nb matrix
*> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply
*> the transformation to the unreduced part of the matrix, using a block
*> update of the form: A := A - V*Y**H - X*U**H.
*>
*> The contents of A on exit are illustrated by the following examples
*> with nb = 2:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
*> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
*> ( v1 v2 a a a ) ( v1 1 a a a a )
*> ( v1 v2 a a a ) ( v1 v2 a a a a )
*> ( v1 v2 a a a ) ( v1 v2 a a a a )
*> ( v1 v2 a a a )
*>
*> where a denotes an element of the original matrix which is unchanged,
*> vi denotes an element of the vector defining H(i), and ui an element
*> of the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
$ LDY )
*
* -- LAPACK auxiliary routine (version 3.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 LDA, LDX, LDY, M, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
$ Y( LDY, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, NB
*
* Update A(i:m,i)
*
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+1:m,i)
*
ALPHA = A( I, I )
CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = ALPHA
IF( I.LT.N ) THEN
A( I, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
$ A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
$ Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
$ A( I, 1 ), LDA, A( I, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
$ X( I, 1 ), LDX, A( I, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
$ Y( I+1, I ), 1 )
CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
*
* Update A(i,i+1:n)
*
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZLACGV( I, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
CALL ZLACGV( I, A( I, 1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
$ A( I, I+1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
*
* Generate reflection P(i) to annihilate A(i,i+2:n)
*
ALPHA = A( I, I+1 )
CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
$ TAUP( I ) )
E( I ) = ALPHA
A( I, I+1 ) = ONE
*
* Compute X(i+1:m,i)
*
CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
$ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
$ X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
$ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, NB
*
* Update A(i,i:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
$ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
$ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
$ LDA )
CALL ZLACGV( I-1, X( I, 1 ), LDX )
*
* Generate reflection P(i) to annihilate A(i,i+1:n)
*
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = ALPHA
IF( I.LT.M ) THEN
A( I, I ) = ONE
*
* Compute X(i+1:m,i)
*
CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
$ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
$ X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
$ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
$ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
CALL ZLACGV( N-I+1, A( I, I ), LDA )
*
* Update A(i+1:m,i)
*
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
CALL ZLACGV( I-1, Y( I, 1 ), LDY )
CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
$ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
*
* Generate reflection Q(i) to annihilate A(i+2:m,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Compute Y(i+1:n,i)
*
CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
$ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
$ Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
$ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
$ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
$ Y( 1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
$ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
$ Y( I+1, I ), 1 )
CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
ELSE
CALL ZLACGV( N-I+1, A( I, I ), LDA )
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZLABRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgebd2.f 0000644 0000000 0000000 00000000132 14061636515 015201 x ustar 00 30 mtime=1623670093.308103984
30 atime=1623670093.307103984
30 ctime=1623670093.308103984
elk-7.2.42/src/LAPACK/zgebd2.f 0000644 0025044 0025044 00000024303 14061636515 017240 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEBD2 reduces a complex general m by n matrix A to upper or lower
*> real bidiagonal form B by a unitary transformation: Q**H * A * P = B.
*>
*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows in the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n general matrix to be reduced.
*> On exit,
*> if m >= n, the diagonal and the first superdiagonal are
*> overwritten with the upper bidiagonal matrix B; the
*> elements below the diagonal, with the array TAUQ, represent
*> the unitary matrix Q as a product of elementary
*> reflectors, and the elements above the first superdiagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors;
*> if m < n, the diagonal and the first subdiagonal are
*> overwritten with the lower bidiagonal matrix B; the
*> elements below the first subdiagonal, with the array TAUQ,
*> represent the unitary matrix Q as a product of
*> elementary reflectors, and the elements above the diagonal,
*> with the array TAUP, represent the unitary matrix P as
*> a product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (min(M,N))
*> The diagonal elements of the bidiagonal matrix B:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (min(M,N)-1)
*> The off-diagonal elements of the bidiagonal matrix B:
*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*> \endverbatim
*>
*> \param[out] TAUQ
*> \verbatim
*> TAUQ is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix Q. See Further Details.
*> \endverbatim
*>
*> \param[out] TAUP
*> \verbatim
*> TAUP is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors which
*> represent the unitary matrix P. See Further Details.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (max(M,N))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrices Q and P are represented as products of elementary
*> reflectors:
*>
*> If m >= n,
*>
*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, and v and u are complex
*> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
*> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> If m < n,
*>
*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
*>
*> Each H(i) and G(i) has the form:
*>
*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
*>
*> where tauq and taup are complex scalars, v and u are complex vectors;
*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
*> tauq is stored in TAUQ(i) and taup in TAUP(i).
*>
*> The contents of A on exit are illustrated by the following examples:
*>
*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
*>
*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
*> ( v1 v2 v3 v4 v5 )
*>
*> where d and e denote diagonal and off-diagonal elements of B, vi
*> denotes an element of the vector defining H(i), and ui an element of
*> the vector defining G(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* -- LAPACK computational routine (version 3.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, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.LT.0 ) THEN
CALL XERBLA( 'ZGEBD2', -INFO )
RETURN
END IF
*
IF( M.GE.N ) THEN
*
* Reduce to upper bidiagonal form
*
DO 10 I = 1, N
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
ALPHA = A( I, I )
CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
$ TAUQ( I ) )
D( I ) = ALPHA
A( I, I ) = ONE
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
IF( I.LT.N )
$ CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
A( I, I ) = D( I )
*
IF( I.LT.N ) THEN
*
* Generate elementary reflector G(i) to annihilate
* A(i,i+2:n)
*
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
ALPHA = A( I, I+1 )
CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
$ TAUP( I ) )
E( I ) = ALPHA
A( I, I+1 ) = ONE
*
* Apply G(i) to A(i+1:m,i+1:n) from the right
*
CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
$ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I+1 ) = E( I )
ELSE
TAUP( I ) = ZERO
END IF
10 CONTINUE
ELSE
*
* Reduce to lower bidiagonal form
*
DO 20 I = 1, M
*
* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAUP( I ) )
D( I ) = ALPHA
A( I, I ) = ONE
*
* Apply G(i) to A(i+1:m,i:n) from the right
*
IF( I.LT.M )
$ CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ TAUP( I ), A( I+1, I ), LDA, WORK )
CALL ZLACGV( N-I+1, A( I, I ), LDA )
A( I, I ) = D( I )
*
IF( I.LT.M ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:m,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
$ TAUQ( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Apply H(i)**H to A(i+1:m,i+1:n) from the left
*
CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
$ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
$ WORK )
A( I+1, I ) = E( I )
ELSE
TAUQ( I ) = ZERO
END IF
20 CONTINUE
END IF
RETURN
*
* End of ZGEBD2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlahr2.f 0000644 0000000 0000000 00000000132 14061636515 015226 x ustar 00 30 mtime=1623670093.310103982
30 atime=1623670093.310103982
30 ctime=1623670093.310103982
elk-7.2.42/src/LAPACK/zlahr2.f 0000644 0025044 0025044 00000024157 14061636515 017274 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* .. Scalar Arguments ..
* INTEGER K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
* $ Y( LDY, NB )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
*> matrix A so that elements below the k-th subdiagonal are zero. The
*> reduction is performed by an unitary similarity transformation
*> Q**H * A * Q. The routine returns the matrices V and T which determine
*> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
*>
*> This is an auxiliary routine called by ZGEHRD.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The offset for the reduction. Elements below the k-th
*> subdiagonal in the first NB columns are reduced to zero.
*> K < N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of columns to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N-K+1)
*> On entry, the n-by-(n-k+1) general matrix A.
*> On exit, the elements on and above the k-th subdiagonal in
*> the first NB columns are overwritten with the corresponding
*> elements of the reduced matrix; the elements below the k-th
*> subdiagonal, with the array TAU, represent the matrix Q as a
*> product of elementary reflectors. The other columns of A are
*> unchanged. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (NB)
*> The scalar factors of the elementary reflectors. See Further
*> Details.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NB)
*> The upper triangular matrix T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= NB.
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*> Y is COMPLEX*16 array, dimension (LDY,NB)
*> The n-by-nb matrix Y.
*> \endverbatim
*>
*> \param[in] LDY
*> \verbatim
*> LDY is INTEGER
*> The leading dimension of the array Y. LDY >= N.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of nb elementary reflectors
*>
*> Q = H(1) H(2) . . . H(nb).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
*> A(i+k+1:n,i), and tau in TAU(i).
*>
*> The elements of the vectors v together form the (n-k+1)-by-nb matrix
*> V which is needed, with T and Y, to apply the transformation to the
*> unreduced part of the matrix, using an update of the form:
*> A := (I - V*T*V**H) * (A - Y*V**H).
*>
*> The contents of A on exit are illustrated by the following example
*> with n = 7, k = 3 and nb = 2:
*>
*> ( a a a a a )
*> ( a a a a a )
*> ( a a a a a )
*> ( h h a a a )
*> ( v1 h a a a )
*> ( v1 v2 a a a )
*> ( v1 v2 a a a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*>
*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD
*> incorporating improvements proposed by Quintana-Orti and Van de
*> Gejin. Note that the entries of A(1:K,2:NB) differ from those
*> returned by the original LAPACK-3.0's DLAHRD routine. (This
*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
*> \endverbatim
*
*> \par References:
* ================
*>
*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the
*> performance of reduction to Hessenberg form," ACM Transactions on
*> Mathematical Software, 32(2):180-194, June 2006.
*>
* =====================================================================
SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.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 K, LDA, LDT, LDY, N, NB
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
$ Y( LDY, NB )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 EI
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY,
$ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
DO 10 I = 1, NB
IF( I.GT.1 ) THEN
*
* Update A(K+1:N,I)
*
* Update I-th column of A - Y * V**H
*
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
$ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
*
* Apply I - V * T**H * V**H to this column (call it b) from the
* left, using the last column of T as workspace
*
* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
* ( V2 ) ( b2 )
*
* where V1 is unit lower triangular
*
* w := V1**H * b1
*
CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT',
$ I-1, A( K+1, 1 ),
$ LDA, T( 1, NB ), 1 )
*
* w := w + V2**H * b2
*
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ),
$ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
*
* w := T**H * w
*
CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, NB ), 1 )
*
* b2 := b2 - V2*w
*
CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
$ A( K+I, 1 ),
$ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
*
* b1 := b1 - V1*w
*
CALL ZTRMV( 'Lower', 'NO TRANSPOSE',
$ 'UNIT', I-1,
$ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
*
A( K+I-1, I-1 ) = EI
END IF
*
* Generate the elementary reflector H(I) to annihilate
* A(K+I+1:N,I)
*
CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
$ TAU( I ) )
EI = A( K+I, I )
A( K+I, I ) = ONE
*
* Compute Y(K+1:N,I)
*
CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
$ ONE, A( K+1, I+1 ),
$ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1,
$ ONE, A( K+I, 1 ), LDA,
$ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
$ Y( K+1, 1 ), LDY,
$ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
*
* Compute T(1:I,I)
*
CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT',
$ I-1, T, LDT,
$ T( 1, I ), 1 )
T( I, I ) = TAU( I )
*
10 CONTINUE
A( K+NB, NB ) = EI
*
* Compute Y(1:K,1:NB)
*
CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
$ 'UNIT', K, NB,
$ ONE, A( K+1, 1 ), LDA, Y, LDY )
IF( N.GT.K+NB )
$ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
$ NB, N-K-NB, ONE,
$ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
$ LDY )
CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
$ 'NON-UNIT', K, NB,
$ ONE, T, LDT, Y, LDY )
*
RETURN
*
* End of ZLAHR2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlarfb.f 0000644 0000000 0000000 00000000127 14061636515 015310 x ustar 00 29 mtime=1623670093.31210398
29 atime=1623670093.31210398
29 ctime=1623670093.31210398
elk-7.2.42/src/LAPACK/zlarfb.f 0000644 0025044 0025044 00000053371 14061636515 017352 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
* T, LDT, C, LDC, WORK, LDWORK )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, SIDE, STOREV, TRANS
* INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFB applies a complex block reflector H or its transpose H**H to a
*> complex M-by-N matrix C, from either the left or the right.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply H or H**H from the Left
*> = 'R': apply H or H**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'C': apply H**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Indicates how H is formed from a product of elementary
*> reflectors
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Indicates how the vectors which define the elementary
*> reflectors are stored:
*> = 'C': Columnwise
*> = 'R': Rowwise
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the matrix T (= the number of elementary
*> reflectors whose product defines the block reflector).
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,M) if STOREV = 'R' and SIDE = 'L'
*> (LDV,N) if STOREV = 'R' and SIDE = 'R'
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*> if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The triangular K-by-K matrix T in the representation of the
*> block reflector.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2013
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* June 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
IF( LSAME( STOREV, 'C' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 ) (first K rows)
* ( V2 )
* where V1 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C1**H
*
DO 10 J = 1, K
CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C( K+1, 1 ), LDC,
$ V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
$ LDWORK, ONE, C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 30 J = 1, K
DO 20 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
$ ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
$ LDV, ONE, C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 60 J = 1, K
DO 50 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
50 CONTINUE
60 CONTINUE
END IF
*
ELSE
*
* Let V = ( V1 )
* ( V2 ) (last K rows)
* where V2 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK)
*
* W := C2**H
*
DO 70 J = 1, K
CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
$ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**H
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose',
$ M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
$ ONE, C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W**H
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1
*
CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**H
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
$ C, LDC )
END IF
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
$ LDWORK )
*
* C2 := C2 - W
*
DO 120 J = 1, K
DO 110 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
110 CONTINUE
120 CONTINUE
END IF
END IF
*
ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
*
* Let V = ( V1 V2 ) (V1: first K columns)
* where V1 is unit upper triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C1**H
*
DO 130 J = 1, K
CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**H * V2**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, N, K, -ONE,
$ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**H
*
DO 150 J = 1, K
DO 140 I = 1, N
C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**H
*
CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C( 1, K+1 ), LDC,
$ V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2
*
CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1
*
CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 180 J = 1, K
DO 170 I = 1, M
C( I, J ) = C( I, J ) - WORK( I, J )
170 CONTINUE
180 CONTINUE
*
END IF
*
ELSE
*
* Let V = ( V1 V2 ) (V2: last K columns)
* where V2 is unit lower triangular.
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C or H**H * C where C = ( C1 )
* ( C2 )
*
* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
*
* W := C2**H
*
DO 190 J = 1, K
CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
CALL ZLACGV( N, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
$ LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**H * V1**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', N, K, M-K, ONE, C,
$ LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**H or W * T
*
CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**H * W**H
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1**H * W**H
*
CALL ZGEMM( 'Conjugate transpose',
$ 'Conjugate transpose', M-K, N, K, -ONE, V,
$ LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**H
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) -
$ DCONJG( WORK( I, J ) )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**H where C = ( C1 C2 )
*
* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**H
*
CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
$ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
$ LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**H
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
$ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
$ LDWORK )
END IF
*
* W := W * T or W * T**H
*
CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1
*
CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
* C1 := C1 - W
*
DO 240 J = 1, K
DO 230 I = 1, M
C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
230 CONTINUE
240 CONTINUE
*
END IF
*
END IF
END IF
*
RETURN
*
* End of ZLARFB
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgehd2.f 0000644 0000000 0000000 00000000132 14061636515 015207 x ustar 00 30 mtime=1623670093.314103978
30 atime=1623670093.314103978
30 ctime=1623670093.314103978
elk-7.2.42/src/LAPACK/zgehd2.f 0000644 0025044 0025044 00000014673 14061636515 017257 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEHD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
*> by a unitary similarity transformation: Q**H * A * Q = H .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that A is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*> set by a previous call to ZGEBAL; otherwise they should be
*> set to 1 and N respectively. See Further Details.
*> 1 <= ILO <= IHI <= max(1,N).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the n by n general matrix to be reduced.
*> On exit, the upper triangle and the first subdiagonal of A
*> are overwritten with the upper Hessenberg matrix H, and the
*> elements below the first subdiagonal, with the array TAU,
*> represent the unitary matrix Q as a product of elementary
*> reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of (ihi-ilo) elementary
*> reflectors
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*> exit in A(i+2:ihi,i), and tau in TAU(i).
*>
*> The contents of A are illustrated by the following example, with
*> n = 7, ilo = 2 and ihi = 6:
*>
*> on entry, on exit,
*>
*> ( a a a a a a a ) ( a a h h h h a )
*> ( a a a a a a ) ( a h h h h a )
*> ( a a a a a a ) ( h h h h h h )
*> ( a a a a a a ) ( v2 h h h h h )
*> ( a a a a a a ) ( v2 v3 h h h h )
*> ( a a a a a a ) ( v2 v3 v4 h h h )
*> ( a ) ( a )
*>
*> where a denotes an element of the original matrix A, h denotes a
*> modified element of the upper Hessenberg matrix H, and vi denotes an
*> element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.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 IHI, ILO, INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEHD2', -INFO )
RETURN
END IF
*
DO 10 I = ILO, IHI - 1
*
* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) )
A( I+1, I ) = ONE
*
* Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
$ A( 1, I+1 ), LDA, WORK )
*
* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
*
CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
$ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
*
A( I+1, I ) = ALPHA
10 CONTINUE
*
RETURN
*
* End of ZGEHD2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgelq2.f 0000644 0000000 0000000 00000000132 14061636515 015230 x ustar 00 30 mtime=1623670093.316103976
30 atime=1623670093.316103976
30 ctime=1623670093.316103976
elk-7.2.42/src/LAPACK/zgelq2.f 0000644 0025044 0025044 00000012447 14061636515 017275 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELQ2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGELQ2 computes an LQ factorization of a complex m-by-n matrix A:
*>
*> A = ( L 0 ) * Q
*>
*> where:
*>
*> Q is a n-by-n orthogonal matrix;
*> L is an lower-triangular m-by-m matrix;
*> 0 is a m-by-(n-m) zero matrix, if m < n.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and below the diagonal of the array
*> contain the m by min(m,n) lower trapezoidal matrix L (L is
*> lower triangular if m <= n); the elements above the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
*> A(i,i+1:n), and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, K
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGELQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
*
CALL ZLACGV( N-I+1, A( I, I ), LDA )
ALPHA = A( I, I )
CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
$ TAU( I ) )
IF( I.LT.M ) THEN
*
* Apply H(i) to A(i+1:m,i:n) from the right
*
A( I, I ) = ONE
CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
$ A( I+1, I ), LDA, WORK )
END IF
A( I, I ) = ALPHA
CALL ZLACGV( N-I+1, A( I, I ), LDA )
10 CONTINUE
RETURN
*
* End of ZGELQ2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlarft.f 0000644 0000000 0000000 00000000132 14061636515 015326 x ustar 00 30 mtime=1623670093.318103974
30 atime=1623670093.318103974
30 ctime=1623670093.318103974
elk-7.2.42/src/LAPACK/zlarft.f 0000644 0025044 0025044 00000024155 14061636515 017372 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFT forms the triangular factor T of a complex block reflector H
*> of order n, which is defined as a product of k elementary reflectors.
*>
*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*>
*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*>
*> If STOREV = 'C', the vector which defines the elementary reflector
*> H(i) is stored in the i-th column of the array V, and
*>
*> H = I - V * T * V**H
*>
*> If STOREV = 'R', the vector which defines the elementary reflector
*> H(i) is stored in the i-th row of the array V, and
*>
*> H = I - V**H * T * V
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIRECT
*> \verbatim
*> DIRECT is CHARACTER*1
*> Specifies the order in which the elementary reflectors are
*> multiplied to form the block reflector:
*> = 'F': H = H(1) H(2) . . . H(k) (Forward)
*> = 'B': H = H(k) . . . H(2) H(1) (Backward)
*> \endverbatim
*>
*> \param[in] STOREV
*> \verbatim
*> STOREV is CHARACTER*1
*> Specifies how the vectors which define the elementary
*> reflectors are stored (see also Further Details):
*> = 'C': columnwise
*> = 'R': rowwise
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the block reflector H. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The order of the triangular factor T (= the number of
*> elementary reflectors). K >= 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (LDV,K) if STOREV = 'C'
*> (LDV,N) if STOREV = 'R'
*> The matrix V. See further details.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of the array V.
*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.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 DIRECT, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZTRMV, ZGEMM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( PREVLASTV, I )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * CONJG( V( I , J ) )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i)
*
CALL ZGEMV( 'Conjugate transpose', J-I, I-1,
$ -TAU( I ), V( I+1, 1 ), LDV,
$ V( I+1, I ), 1, ONE, T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
*
CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV,
$ ONE, T( 1, I ), LDT )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
*
CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I,
$ -TAU( I ), V( J, I+1 ), LDV, V( J, I ),
$ 1, ONE, T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
*
CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ),
$ V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), LDT )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of ZLARFT
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zgeqr2.f 0000644 0000000 0000000 00000000132 14061636515 015236 x ustar 00 30 mtime=1623670093.320103972
30 atime=1623670093.320103972
30 ctime=1623670093.320103972
elk-7.2.42/src/LAPACK/zgeqr2.f 0000644 0025044 0025044 00000012335 14061636515 017277 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZGEQR2 computes a QR factorization of a complex m-by-n matrix A:
*>
*> A = Q * ( R ),
*> ( 0 )
*>
*> where:
*>
*> Q is a m-by-m orthogonal matrix;
*> R is an upper-triangular n-by-n matrix;
*> 0 is a (m-n)-by-n zero matrix, if m > n.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and above the diagonal of the array
*> contain the min(m,n) by n upper trapezoidal matrix R (R is
*> upper triangular if m >= n); the elements below the diagonal,
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2019
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine (version 3.9.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2019
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, K
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZLARFG
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZGEQR2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAU( I ) )
IF( I.LT.N ) THEN
*
* Apply H(i)**H to A(i:m,i+1:n) from the left
*
ALPHA = A( I, I )
A( I, I ) = ONE
CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
$ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
A( I, I ) = ALPHA
END IF
10 CONTINUE
RETURN
*
* End of ZGEQR2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhegs2.f 0000644 0000000 0000000 00000000130 14061636515 015224 x ustar 00 29 mtime=1623670093.32210397
30 atime=1623670093.321103971
29 ctime=1623670093.32210397
elk-7.2.42/src/LAPACK/zhegs2.f 0000644 0025044 0025044 00000022513 14061636515 017266 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHEGS2 reduces a Hermitian definite generalized eigenproblem to standard form, using the factorization results obtained from cpotrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHEGS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHEGS2 reduces a complex Hermitian-definite generalized
*> eigenproblem to standard form.
*>
*> If ITYPE = 1, the problem is A*x = lambda*B*x,
*> and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
*>
*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
*> B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H *A*L.
*>
*> B must have been previously factorized as U**H *U or L*L**H by ZPOTRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] ITYPE
*> \verbatim
*> ITYPE is INTEGER
*> = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
*> = 2 or 3: compute U*A*U**H or L**H *A*L.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored, and how B has been factorized.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n by n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n by n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the transformed matrix, stored in the
*> same format as A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX*16 array, dimension (LDB,N)
*> The triangular factor from the Cholesky factorization of B,
*> as returned by ZPOTRF.
*> B is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEcomputational
*
* =====================================================================
SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, 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 UPLO
INTEGER INFO, ITYPE, LDA, LDB, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, HALF
PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER K
DOUBLE PRECISION AKK, BKK
COMPLEX*16 CT
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV,
$ ZTRSV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
INFO = -1
ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHEGS2', -INFO )
RETURN
END IF
*
IF( ITYPE.EQ.1 ) THEN
IF( UPPER ) THEN
*
* Compute inv(U**H)*A*inv(U)
*
DO 10 K = 1, N
*
* Update the upper triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
CT = -HALF*AKK
CALL ZLACGV( N-K, A( K, K+1 ), LDA )
CALL ZLACGV( N-K, B( K, K+1 ), LDB )
CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
$ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL ZLACGV( N-K, B( K, K+1 ), LDB )
CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
$ N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
$ LDA )
CALL ZLACGV( N-K, A( K, K+1 ), LDA )
END IF
10 CONTINUE
ELSE
*
* Compute inv(L)*A*inv(L**H)
*
DO 20 K = 1, N
*
* Update the lower triangle of A(k:n,k:n)
*
AKK = A( K, K )
BKK = B( K, K )
AKK = AKK / BKK**2
A( K, K ) = AKK
IF( K.LT.N ) THEN
CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
CT = -HALF*AKK
CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
$ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
$ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
END IF
20 CONTINUE
END IF
ELSE
IF( UPPER ) THEN
*
* Compute U*A*U**H
*
DO 30 K = 1, N
*
* Update the upper triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
$ LDB, A( 1, K ), 1 )
CT = HALF*AKK
CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
$ A, LDA )
CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 )
A( K, K ) = AKK*BKK**2
30 CONTINUE
ELSE
*
* Compute L**H *A*L
*
DO 40 K = 1, N
*
* Update the lower triangle of A(1:k,1:k)
*
AKK = A( K, K )
BKK = B( K, K )
CALL ZLACGV( K-1, A( K, 1 ), LDA )
CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
$ B, LDB, A( K, 1 ), LDA )
CT = HALF*AKK
CALL ZLACGV( K-1, B( K, 1 ), LDB )
CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
$ LDB, A, LDA )
CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
CALL ZLACGV( K-1, B( K, 1 ), LDB )
CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA )
CALL ZLACGV( K-1, A( K, 1 ), LDA )
A( K, K ) = AKK*BKK**2
40 CONTINUE
END IF
END IF
RETURN
*
* End of ZHEGS2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlatrd.f 0000644 0000000 0000000 00000000131 14061636515 015323 x ustar 00 30 mtime=1623670093.324103969
29 atime=1623670093.32310397
30 ctime=1623670093.324103969
elk-7.2.42/src/LAPACK/zlatrd.f 0000644 0025044 0025044 00000030404 14061636515 017362 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDW, N, NB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION E( * )
* COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
*> Hermitian tridiagonal form by a unitary similarity
*> transformation Q**H * A * Q, and returns the matrices V and W which are
*> needed to apply the transformation to the unreduced part of A.
*>
*> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
*> matrix, of which the upper triangle is supplied;
*> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
*> matrix, of which the lower triangle is supplied.
*>
*> This is an auxiliary routine called by ZHETRD.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*> NB is INTEGER
*> The number of rows and columns to be reduced.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit:
*> if UPLO = 'U', the last NB columns have been reduced to
*> tridiagonal form, with the diagonal elements overwriting
*> the diagonal elements of A; the elements above the diagonal
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors;
*> if UPLO = 'L', the first NB columns have been reduced to
*> tridiagonal form, with the diagonal elements overwriting
*> the diagonal elements of A; the elements below the diagonal
*> with the array TAU, represent the unitary matrix Q as a
*> product of elementary reflectors.
*> See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
*> elements of the last NB columns of the reduced matrix;
*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
*> the first NB columns of the reduced matrix.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors, stored in
*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
*> See Further Details.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (LDW,NB)
*> The n-by-nb matrix W required to update the unreduced part
*> of A.
*> \endverbatim
*>
*> \param[in] LDW
*> \verbatim
*> LDW is INTEGER
*> The leading dimension of the array W. LDW >= max(1,N).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n) H(n-1) . . . H(n-nb+1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
*> and tau in TAU(i-1).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(nb).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
*> and tau in TAU(i).
*>
*> The elements of the vectors v together form the n-by-nb matrix V
*> which is needed, with W, to apply the transformation to the unreduced
*> part of the matrix, using a Hermitian rank-2k update of the form:
*> A := A - V*W**H - W*V**H.
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5 and nb = 2:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( a a a v4 v5 ) ( d )
*> ( a a v4 v5 ) ( 1 d )
*> ( a 1 v5 ) ( v1 1 a )
*> ( d 1 ) ( v1 v2 a a )
*> ( d ) ( v1 v2 a a a )
*>
*> where d denotes a diagonal element of the reduced matrix, a denotes
*> an element of the original matrix that is unchanged, and vi denotes
*> an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 3.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, LDW, N, NB
* ..
* .. Array Arguments ..
DOUBLE PRECISION E( * )
COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE, HALF
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, IW
COMPLEX*16 ALPHA
* ..
* .. External Subroutines ..
EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Reduce last NB columns of upper triangle
*
DO 10 I = N, N - NB + 1, -1
IW = I - N + NB
IF( I.LT.N ) THEN
*
* Update A(1:i,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
$ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
$ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
END IF
IF( I.GT.1 ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(1:i-2,i)
*
ALPHA = A( I-1, I )
CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
E( I-1 ) = ALPHA
A( I-1, I ) = ONE
*
* Compute W(1:i-1,i)
*
CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
$ ZERO, W( 1, IW ), 1 )
IF( I.LT.N ) THEN
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
$ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
$ W( I+1, IW ), 1 )
CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
$ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
$ W( 1, IW ), 1 )
END IF
CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
$ A( 1, I ), 1 )
CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
END IF
*
10 CONTINUE
ELSE
*
* Reduce first NB columns of lower triangle
*
DO 20 I = 1, NB
*
* Update A(i:n,i)
*
A( I, I ) = DBLE( A( I, I ) )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
$ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, W( I, 1 ), LDW )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
$ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
CALL ZLACGV( I-1, A( I, 1 ), LDA )
A( I, I ) = DBLE( A( I, I ) )
IF( I.LT.N ) THEN
*
* Generate elementary reflector H(i) to annihilate
* A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
$ TAU( I ) )
E( I ) = ALPHA
A( I+1, I ) = ONE
*
* Compute W(i+1:n,i)
*
CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
$ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
$ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
$ W( 1, I ), 1 )
CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
$ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
$ A( I+1, I ), 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
END IF
*
20 CONTINUE
END IF
*
RETURN
*
* End of ZLATRD
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zhetd2.f 0000644 0000000 0000000 00000000132 14061636515 015224 x ustar 00 30 mtime=1623670093.326103967
30 atime=1623670093.326103967
30 ctime=1623670093.326103967
elk-7.2.42/src/LAPACK/zhetd2.f 0000644 0025044 0025044 00000023711 14061636515 017265 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZHETD2 reduces a Hermitian matrix to real symmetric tridiagonal form by an unitary similarity transformation (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZHETD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), E( * )
* COMPLEX*16 A( LDA, * ), TAU( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZHETD2 reduces a complex Hermitian matrix A to real symmetric
*> tridiagonal form T by a unitary similarity transformation:
*> Q**H * A * Q = T.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the upper or lower triangular part of the
*> Hermitian matrix A is stored:
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> n-by-n upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n-by-n lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*> On exit, if UPLO = 'U', the diagonal and first superdiagonal
*> of A are overwritten by the corresponding elements of the
*> tridiagonal matrix T, and the elements above the first
*> superdiagonal, with the array TAU, represent the unitary
*> matrix Q as a product of elementary reflectors; if UPLO
*> = 'L', the diagonal and first subdiagonal of A are over-
*> written by the corresponding elements of the tridiagonal
*> matrix T, and the elements below the first subdiagonal, with
*> the array TAU, represent the unitary matrix Q as a product
*> of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> The diagonal elements of the tridiagonal matrix T:
*> D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> The off-diagonal elements of the tridiagonal matrix T:
*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (N-1)
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16HEcomputational
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> If UPLO = 'U', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(n-1) . . . H(2) H(1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
*> A(1:i-1,i+1), and tau in TAU(i).
*>
*> If UPLO = 'L', the matrix Q is represented as a product of elementary
*> reflectors
*>
*> Q = H(1) H(2) . . . H(n-1).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**H
*>
*> where tau is a complex scalar, and v is a complex vector with
*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
*> and tau in TAU(i).
*>
*> The contents of A on exit are illustrated by the following examples
*> with n = 5:
*>
*> if UPLO = 'U': if UPLO = 'L':
*>
*> ( d e v2 v3 v4 ) ( d )
*> ( d e v3 v4 ) ( e d )
*> ( d e v4 ) ( v1 e d )
*> ( d e ) ( v1 v2 e d )
*> ( d ) ( v1 v2 v3 e d )
*>
*> where d and e denote diagonal and off-diagonal elements of T, and vi
*> denotes an element of the vector defining H(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK computational routine (version 3.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 INFO, LDA, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 A( LDA, * ), TAU( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U')
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHETD2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A
*
A( N, N ) = DBLE( A( N, N ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(1:i-1,i+1)
*
ALPHA = A( I, I+1 )
CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
A( I, I+1 ) = ONE
*
* Compute x := tau * A * v storing x in TAU(1:i)
*
CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
$ TAU, 1 )
*
* Compute w := x - 1/2 * tau * (x**H * v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
$ LDA )
*
ELSE
A( I, I ) = DBLE( A( I, I ) )
END IF
A( I, I+1 ) = E( I )
D( I+1 ) = A( I+1, I+1 )
TAU( I ) = TAUI
10 CONTINUE
D( 1 ) = A( 1, 1 )
ELSE
*
* Reduce the lower triangle of A
*
A( 1, 1 ) = DBLE( A( 1, 1 ) )
DO 20 I = 1, N - 1
*
* Generate elementary reflector H(i) = I - tau * v * v**H
* to annihilate A(i+2:n,i)
*
ALPHA = A( I+1, I )
CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
A( I+1, I ) = ONE
*
* Compute x := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
$ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
*
* Compute w := x - 1/2 * tau * (x**H * v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w**H - w * v**H
*
CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
$ A( I+1, I+1 ), LDA )
*
ELSE
A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
END IF
A( I+1, I ) = E( I )
D( I ) = A( I, I )
TAU( I ) = TAUI
20 CONTINUE
D( N ) = A( N, N )
END IF
*
RETURN
*
* End of ZHETD2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlarfg.f 0000644 0000000 0000000 00000000132 14061636515 015311 x ustar 00 30 mtime=1623670093.328103965
30 atime=1623670093.328103965
30 ctime=1623670093.328103965
elk-7.2.42/src/LAPACK/zlarfg.f 0000644 0025044 0025044 00000012455 14061636515 017355 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARFG generates a complex elementary reflector H of order n, such
*> that
*>
*> H**H * ( alpha ) = ( beta ), H**H * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, with beta real, and x is an
*> (n-1)-element complex vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**H ) ,
*> ( v )
*>
*> where tau is a complex scalar and v is a complex (n-1)-element
*> vector. Note that H is not hermitian.
*>
*> If the elements of x are all zero and alpha is real, then tau = 0
*> and H is taken to be the unit matrix.
*>
*> Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is COMPLEX*16
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.8.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHR = DBLE( ALPHA )
ALPHI = DIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHA = DCMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of ZLARFG
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr0.f 0000644 0000000 0000000 00000000132 14061636515 015235 x ustar 00 30 mtime=1623670093.330103963
30 atime=1623670093.329103964
30 ctime=1623670093.330103963
elk-7.2.42/src/LAPACK/zlaqr0.f 0000644 0025044 0025044 00000060726 14061636515 017305 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR0 computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N > 0, then 1 <= ILO <= IHI <= N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO > 0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i > j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO > 0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR0 does a workspace query.
*> In this case, ZLAQR0 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = i, ZLAQR0 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO > 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO > 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO > 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO > 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by varying the size of the
* . deflation window after KEXNW iterations. ====
INTEGER KEXNW
PARAMETER ( KEXNW = 5 )
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . ====
INTEGER KEXSH
PARAMETER ( KEXSH = 6 )
*
* ==== The constant WILK1 is used to form the exceptional
* . shifts. ====
DOUBLE PRECISION WILK1
PARAMETER ( WILK1 = 0.75d0 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
DOUBLE PRECISION S
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
$ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
LOGICAL SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
COMPLEX*16 ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
$ SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
IF( N.LE.NTINY ) THEN
*
* ==== Tiny matrices must use ZLAHQR. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to ZLAQR3 ====
*
CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
$ LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
NW = NWMAX
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 70 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 80
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size:
* . Typical Case:
* . If possible and advisable, nibble the entire
* . active block. If not, use size MIN(NWR,NWMAX)
* . or MIN(NWR+1,NWMAX) depending upon which has
* . the smaller corresponding subdiagonal entry
* . (a heuristic).
* .
* . Exceptional Case:
* . If there have been no deflations in KEXNW or
* . more iterations, then vary the deflation window
* . size. At first, because, larger windows are,
* . in general, more powerful than smaller ones,
* . rapidly increase the window to the maximum possible.
* . Then, gradually reduce the window size. ====
*
NH = KBOT - KTOP + 1
NWUPBD = MIN( NH, NWMAX )
IF( NDFL.LT.KEXNW ) THEN
NW = MIN( NWUPBD, NWR )
ELSE
NW = MIN( NWUPBD, 2*NW )
END IF
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
$ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
IF( NDFL.LT.KEXNW ) THEN
NDEC = -1
ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
NDEC = NDEC + 1
IF( NW-NDEC.LT.2 )
$ NDEC = 0
NW = NW - NDEC
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
$ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
$ LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if ZLAQR3
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . ZLAQR3 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, KS + 1, -2
W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
W( I-1 ) = W( I )
30 CONTINUE
ELSE
*
* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or
* . ZLAHQR on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
IF( NS.GT.NMIN ) THEN
CALL ZLAQR4( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1,
$ ZDUM, 1, WORK, LWORK, INF )
ELSE
CALL ZLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1,
$ ZDUM, 1, INF )
END IF
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. Scale to avoid
* . overflows, underflows and subnormals.
* . (The scale factor S can not be zero,
* . because H(KBOT,KBOT-1) is nonzero.) ====
*
IF( KS.GE.KBOT ) THEN
S = CABS1( H( KBOT-1, KBOT-1 ) ) +
$ CABS1( H( KBOT, KBOT-1 ) ) +
$ CABS1( H( KBOT-1, KBOT ) ) +
$ CABS1( H( KBOT, KBOT ) )
AA = H( KBOT-1, KBOT-1 ) / S
CC = H( KBOT, KBOT-1 ) / S
BB = H( KBOT-1, KBOT ) / S
DD = H( KBOT, KBOT ) / S
TR2 = ( AA+DD ) / TWO
DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
RTDISC = SQRT( -DET )
W( KBOT-1 ) = ( TR2+RTDISC )*S
W( KBOT ) = ( TR2-RTDISC )*S
*
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little) ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
$ THEN
SORTED = .false.
SWAP = W( I )
W( I ) = W( I+1 )
W( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
END IF
*
* ==== If there are only two shifts, then use
* . only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
$ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
W( KBOT-1 ) = W( KBOT )
ELSE
W( KBOT ) = W( KBOT-1 )
END IF
END IF
*
* ==== Use up to NS of the the smallest magnitude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR0 ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlahqr.f 0000644 0000000 0000000 00000000132 14061636515 015325 x ustar 00 30 mtime=1623670093.332103961
30 atime=1623670093.332103961
30 ctime=1623670093.332103961
elk-7.2.42/src/LAPACK/zlahqr.f 0000644 0025044 0025044 00000044054 14061636515 017371 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAHQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAHQR is an auxiliary routine called by CHSEQR to update the
*> eigenvalues and Schur decomposition already computed by CHSEQR, by
*> dealing with the Hessenberg submatrix in rows and columns ILO to
*> IHI.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> It is assumed that H is already upper triangular in rows and
*> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
*> ZLAHQR works primarily with the Hessenberg submatrix in rows
*> and columns ILO to IHI, but applies transformations to all of
*> H if WANTT is .TRUE..
*> 1 <= ILO <= max(1,IHI); IHI <= N.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO is zero and if WANTT is .TRUE., then H
*> is upper triangular in rows and columns ILO:IHI. If INFO
*> is zero and if WANTT is .FALSE., then the contents of H
*> are unspecified on exit. The output state of H in case
*> INF is positive is below under the description of INFO.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues ILO to IHI are stored in the
*> corresponding elements of W. If WANTT is .TRUE., the
*> eigenvalues are stored in the same order as on the diagonal
*> of the Schur form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> If WANTZ is .TRUE., on entry Z must contain the current
*> matrix Z of transformations accumulated by CHSEQR, and on
*> exit Z has been updated; transformations are applied only to
*> the submatrix Z(ILOZ:IHIZ,ILO:IHI).
*> If WANTZ is .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = i, ZLAHQR failed to compute all the
*> eigenvalues ILO to IHI in a total of 30 iterations
*> per eigenvalue; elements i+1:ihi of W contain
*> those eigenvalues which have been successfully
*> computed.
*>
*> If INFO > 0 and WANTT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the
*> eigenvalues of the upper Hessenberg matrix
*> rows and columns ILO through INFO of the final,
*> output value of H.
*>
*> If INFO > 0 and WANTT is .TRUE., then on exit
*> (*) (initial value of H)*U = U*(final value of H)
*> where U is an orthogonal matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO > 0 and WANTZ is .TRUE., then on exit
*> (final value of Z) = (initial value of Z)*U
*> where U is the orthogonal matrix in (*)
*> (regardless of the value of WANTT.)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> \verbatim
*>
*> 02-96 Based on modifications by
*> David Day, Sandia National Laboratory, USA
*>
*> 12-04 Further modifications by
*> Ralph Byers, University of Kansas, USA
*> This is a modified version of ZLAHQR from LAPACK version 3.0.
*> It is (1) more robust against overflow and underflow and
*> (2) adopts the more conservative Ahues & Tisseur stopping
*> criterion (LAWN 122, 1997).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 3.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
* =========================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE, HALF
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
DOUBLE PRECISION DAT1
PARAMETER ( DAT1 = 3.0d0 / 4.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
$ V2, X, Y
DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
$ SAFMIN, SMLNUM, SX, T2, TST, ULP
INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M,
$ NH, NZ
* ..
* .. Local Arrays ..
COMPLEX*16 V( 2 )
* ..
* .. External Functions ..
COMPLEX*16 ZLADIV
DOUBLE PRECISION DLAMCH
EXTERNAL ZLADIV, DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
* ==== clear out the trash ====
DO 10 J = ILO, IHI - 3
H( J+2, J ) = ZERO
H( J+3, J ) = ZERO
10 CONTINUE
IF( ILO.LE.IHI-2 )
$ H( IHI, IHI-2 ) = ZERO
* ==== ensure that subdiagonal entries are real ====
IF( WANTT ) THEN
JLO = 1
JHI = N
ELSE
JLO = ILO
JHI = IHI
END IF
DO 20 I = ILO + 1, IHI
IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
* ==== The following redundant normalization
* . avoids problems with both gradual and
* . sudden underflow in ABS(H(I,I-1)) ====
SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
SC = DCONJG( SC ) / ABS( SC )
H( I, I-1 ) = ABS( H( I, I-1 ) )
CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
$ H( JLO, I ), 1 )
IF( WANTZ )
$ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
END IF
20 CONTINUE
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITMAX is the total number of QR iterations allowed.
*
ITMAX = 30 * MAX( 10, NH )
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
30 CONTINUE
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 splits off at the bottom because a
* subdiagonal element has become negligible.
*
L = ILO
DO 130 ITS = 0, ITMAX
*
* Look for a single small subdiagonal element.
*
DO 40 K = I, L + 1, -1
IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
$ GO TO 50
TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
IF( TST.EQ.ZERO ) THEN
IF( K-2.GE.ILO )
$ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
IF( K+1.LE.IHI )
$ TST = TST + ABS( DBLE( H( K+1, K ) ) )
END IF
* ==== The following is a conservative small subdiagonal
* . deflation criterion due to Ahues & Tisseur (LAWN 122,
* . 1997). It has better mathematical foundation and
* . improves accuracy in some examples. ====
IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
AA = MAX( CABS1( H( K, K ) ),
$ CABS1( H( K-1, K-1 )-H( K, K ) ) )
BB = MIN( CABS1( H( K, K ) ),
$ CABS1( H( K-1, K-1 )-H( K, K ) ) )
S = AA + AB
IF( BA*( AB / S ).LE.MAX( SMLNUM,
$ ULP*( BB*( AA / S ) ) ) )GO TO 50
END IF
40 CONTINUE
50 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 has split off.
*
IF( L.GE.I )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( L+1, L ) ) )
T = S + H( L, L )
ELSE IF( ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
T = S + H( I, I )
ELSE
*
* Wilkinson's shift.
*
T = H( I, I )
U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
S = CABS1( U )
IF( S.NE.RZERO ) THEN
X = HALF*( H( I-1, I-1 )-T )
SX = CABS1( X )
S = MAX( S, CABS1( X ) )
Y = S*SQRT( ( X / S )**2+( U / S )**2 )
IF( SX.GT.RZERO ) THEN
IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
$ DIMAG( Y ).LT.RZERO )Y = -Y
END IF
T = T - U*ZLADIV( U, ( X+Y ) )
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 60 M = I - 1, L + 1, -1
*
* Determine the effect of starting the single-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H11S = H11 - T
H21 = DBLE( H( M+1, M ) )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
H10 = DBLE( H( M, M-1 ) )
IF( ABS( H10 )*ABS( H21 ).LE.ULP*
$ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
$ GO TO 70
60 CONTINUE
H11 = H( L, L )
H22 = H( L+1, L+1 )
H11S = H11 - T
H21 = DBLE( H( L+1, L ) )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
70 CONTINUE
*
* Single-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix.
*
* V(2) is always real before the call to ZLARFG, and hence
* after the call T2 ( = T1*V(2) ) is also real.
*
IF( K.GT.M )
$ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
END IF
V2 = V( 2 )
T2 = DBLE( T1*V2 )
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 80 J = K, I2
SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM
H( K+1, J ) = H( K+1, J ) - SUM*V2
80 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+2,I).
*
DO 90 J = I1, MIN( K+2, I )
SUM = T1*H( J, K ) + T2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM
H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
90 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 100 J = ILOZ, IHIZ
SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM
Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
100 CONTINUE
END IF
*
IF( K.EQ.M .AND. M.GT.L ) THEN
*
* If the QR step was started at row M > L because two
* consecutive small subdiagonals were found, then extra
* scaling must be performed to ensure that H(M,M-1) remains
* real.
*
TEMP = ONE - T1
TEMP = TEMP / ABS( TEMP )
H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
IF( M+2.LE.I )
$ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
DO 110 J = M, I
IF( J.NE.M+1 ) THEN
IF( I2.GT.J )
$ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
$ 1 )
END IF
END IF
110 CONTINUE
END IF
120 CONTINUE
*
* Ensure that H(I,I-1) is real.
*
TEMP = H( I, I-1 )
IF( DIMAG( TEMP ).NE.RZERO ) THEN
RTEMP = ABS( TEMP )
H( I, I-1 ) = RTEMP
TEMP = TEMP / RTEMP
IF( I2.GT.I )
$ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
END IF
END IF
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
W( I ) = H( I, I )
*
* return to start of the main loop with new value of I.
*
I = L - 1
GO TO 30
*
150 CONTINUE
RETURN
*
* End of ZLAHQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlassq.f 0000644 0000000 0000000 00000000132 14061636515 015341 x ustar 00 30 mtime=1623670093.334103959
30 atime=1623670093.334103959
30 ctime=1623670093.334103959
elk-7.2.42/src/LAPACK/zlassq.f 0000644 0025044 0025044 00000011224 14061636515 017376 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLASSQ updates a sum of squares represented in scaled form.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLASSQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLASSQ returns the values scl and ssq such that
*>
*> ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*>
*> where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
*> assumed to be at least unity and the value of ssq will then satisfy
*>
*> 1.0 <= ssq <= ( sumsq + 2*n ).
*>
*> scale is assumed to be non-negative and scl returns the value
*>
*> scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
*> i
*>
*> scale and sumsq must be supplied in SCALE and SUMSQ respectively.
*> SCALE and SUMSQ are overwritten by scl and ssq respectively.
*>
*> The routine makes only one pass through the vector X.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements to be used from the vector X.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (1+(N-1)*INCX)
*> The vector x as described above.
*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of the vector X.
*> INCX > 0.
*> \endverbatim
*>
*> \param[in,out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On entry, the value scale in the equation above.
*> On exit, SCALE is overwritten with the value scl .
*> \endverbatim
*>
*> \param[in,out] SUMSQ
*> \verbatim
*> SUMSQ is DOUBLE PRECISION
*> On entry, the value sumsq in the equation above.
*> On exit, SUMSQ is overwritten with the value ssq .
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- 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 ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION TEMP1
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
TEMP1 = ABS( DBLE( X( IX ) ) )
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
TEMP1 = ABS( DIMAG( X( IX ) ) )
IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
*
RETURN
*
* End of ZLASSQ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zpotrf2.f 0000644 0000000 0000000 00000000132 14061636515 015432 x ustar 00 30 mtime=1623670093.336103957
30 atime=1623670093.336103957
30 ctime=1623670093.336103957
elk-7.2.42/src/LAPACK/zpotrf2.f 0000644 0025044 0025044 00000014454 14061636515 017477 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZPOTRF2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZPOTRF2 computes the Cholesky factorization of a Hermitian
*> positive definite matrix A using the recursive algorithm.
*>
*> The factorization has the form
*> A = U**H * U, if UPLO = 'U', or
*> A = L * L**H, if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the recursive version of the algorithm. It divides
*> the matrix into four submatrices:
*>
*> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2
*> A = [ -----|----- ] with n1 = n/2
*> [ A21 | A22 ] n2 = n-n1
*>
*> The subroutine calls itself to factor A11. Update and scale A21
*> or A12, update A22 then call itself to factor A22.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> = 'U': Upper triangle of A is stored;
*> = 'L': Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading
*> N-by-N upper triangular part of A contains the upper
*> triangular part of the matrix A, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading N-by-N lower triangular part of A contains the lower
*> triangular part of the matrix A, and the strictly upper
*> triangular part of A is not referenced.
*>
*> On exit, if INFO = 0, the factor U or L from the Cholesky
*> factorization A = U**H*U or A = L*L**H.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: if INFO = i, the leading minor of order i is not
*> positive definite, and the factorization could not be
*> completed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16POcomputational
*
* =====================================================================
RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, 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 UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CONE
PARAMETER ( CONE = (1.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER N1, N2, IINFO
DOUBLE PRECISION AJJ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL ZHERK, ZTRSM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, DBLE, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZPOTRF2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* N=1 case
*
IF( N.EQ.1 ) THEN
*
* Test for non-positive-definiteness
*
AJJ = DBLE( A( 1, 1 ) )
IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN
INFO = 1
RETURN
END IF
*
* Factor
*
A( 1, 1 ) = SQRT( AJJ )
*
* Use recursive code
*
ELSE
N1 = N/2
N2 = N-N1
*
* Factor A11
*
CALL ZPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO
RETURN
END IF
*
* Compute the Cholesky factorization A = U**H*U
*
IF( UPPER ) THEN
*
* Update and scale A12
*
CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE,
$ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA )
*
* Update and factor A22
*
CALL ZHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
*
* Compute the Cholesky factorization A = L*L**H
*
ELSE
*
* Update and scale A21
*
CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE,
$ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA )
*
* Update and factor A22
*
CALL ZHERK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA,
$ ONE, A( N1+1, N1+1 ), LDA )
CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO )
IF ( IINFO.NE.0 ) THEN
INFO = IINFO + N1
RETURN
END IF
END IF
END IF
RETURN
*
* End of ZPOTRF2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dstedc.f 0000644 0000000 0000000 00000000132 14061636515 015272 x ustar 00 30 mtime=1623670093.338103956
30 atime=1623670093.338103956
30 ctime=1623670093.338103956
elk-7.2.42/src/LAPACK/dstedc.f 0000644 0025044 0025044 00000036326 14061636515 017341 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DSTEDC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSTEDC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DSTEDC( 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( * )
* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSTEDC 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 DSYTRD or DSPTRD or DSBTRD 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 DLAED3 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 DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, if INFO = 0, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the subdiagonal elements of the tridiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is DOUBLE PRECISION 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 DOUBLE PRECISION 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 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 DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
$ LIWORK, 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 ..
CHARACTER COMPZ
INTEGER INFO, LDZ, LIWORK, LWORK, N
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
$ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
DOUBLE PRECISION EPS, ORGNRM, P, TINY
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
DOUBLE PRECISION DLAMCH, DLANST
EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
$ DSTEQR, DSTERF, DSWAP, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, 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, 'DSTEDC', ' ', 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( DBLE( 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( 'DSTEDC', -INFO )
RETURN
ELSE IF (LQUERY) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( N.EQ.1 ) THEN
IF( ICOMPZ.NE.0 )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* If the following conditional clause is removed, then the routine
* will use the Divide and Conquer routine to compute only the
* eigenvalues, which requires (3N + 3N**2) real workspace and
* (2 + 5N + 2N lg(N)) integer workspace.
* Since on many architectures DSTERF is much faster than any other
* algorithm for finding eigenvalues only, it is used here
* as the default. If the conditional clause is removed, then
* information on the size of workspace needs to be changed.
*
* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
*
IF( ICOMPZ.EQ.0 ) THEN
CALL DSTERF( N, D, E, INFO )
GO TO 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 DSTEQR( 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 DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
END IF
*
* Scale.
*
ORGNRM = DLANST( 'M', N, D, E )
IF( ORGNRM.EQ.ZERO )
$ GO TO 50
*
EPS = DLAMCH( '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 = DLANST( 'M', M, D( START ), E( START ) )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
$ INFO )
CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
$ M-1, INFO )
*
IF( ICOMPZ.EQ.1 ) THEN
STRTRW = 1
ELSE
STRTRW = START
END IF
CALL DLAED0( 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 DLASCL( '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 DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
$ WORK( M*M+1 ), INFO )
CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
$ WORK( STOREZ ), N )
CALL DGEMM( 'N', 'N', N, M, M, ONE,
$ WORK( STOREZ ), N, WORK, M, ZERO,
$ Z( 1, START ), LDZ )
ELSE IF( ICOMPZ.EQ.2 ) THEN
CALL DSTEQR( 'I', M, D( START ), E( START ),
$ Z( START, START ), LDZ, WORK, INFO )
ELSE
CALL DSTERF( 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 DLASRT( '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 DSWAP( 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 DSTEDC
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaed0.f 0000644 0000000 0000000 00000000132 14061636515 015203 x ustar 00 30 mtime=1623670093.340103954
30 atime=1623670093.340103954
30 ctime=1623670093.340103954
elk-7.2.42/src/LAPACK/zlaed0.f 0000644 0025044 0025044 00000026077 14061636515 017254 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAED0 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 ZLAED0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
* IWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION D( * ), E( * ), RWORK( * )
* COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Using the divide and conquer method, ZLAED0 computes all eigenvalues
*> of a symmetric tridiagonal matrix which is one diagonal block of
*> those from reducing a dense or band Hermitian matrix and
*> corresponding eigenvectors of the dense or band matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the diagonal elements of the tridiagonal matrix.
*> On exit, the eigenvalues in ascending order.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (N-1)
*> On entry, the off-diagonal elements of the tridiagonal matrix.
*> On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, Q must contain an QSIZ x N matrix whose columns
*> unitarily orthonormal. It is a part of the unitary matrix
*> that reduces the full dense Hermitian matrix to a
*> (reducible) symmetric tridiagonal matrix.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array,
*> the dimension of IWORK must be at least
*> 6 + 6*N + 5*N*lg N
*> ( lg( N ) = smallest integer k
*> such that 2^k >= N )
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array,
*> dimension (1 + 3*N + 2*N*lg N + 3*N**2)
*> ( lg( N ) = smallest integer k
*> such that 2^k >= N )
*> \endverbatim
*>
*> \param[out] QSTORE
*> \verbatim
*> QSTORE is COMPLEX*16 array, dimension (LDQS, N)
*> Used to store parts of
*> the eigenvector matrix when the updating matrix multiplies
*> take place.
*> \endverbatim
*>
*> \param[in] LDQS
*> \verbatim
*> LDQS is INTEGER
*> The leading dimension of the array QSTORE.
*> LDQS >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: The algorithm failed to compute an eigenvalue while
*> working on the submatrix lying in rows and columns
*> INFO/(N+1) through mod(INFO,N+1).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
$ 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 INFO, LDQ, LDQS, N, QSIZ
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION D( * ), E( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * )
* ..
*
* =====================================================================
*
* Warning: N could be as big as QSIZ!
*
* .. Parameters ..
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.D+0 )
* ..
* .. Local Scalars ..
INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
$ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
$ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
$ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
* INFO = -1
* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
* $ THEN
IF( QSIZ.LT.MAX( 0, N ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
*
* Determine the size and placement of the submatrices, and save in
* the leading elements of IWORK.
*
IWORK( 1 ) = N
SUBPBS = 1
TLVLS = 0
10 CONTINUE
IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
DO 20 J = SUBPBS, 1, -1
IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
IWORK( 2*J-1 ) = IWORK( J ) / 2
20 CONTINUE
TLVLS = TLVLS + 1
SUBPBS = 2*SUBPBS
GO TO 10
END IF
DO 30 J = 2, SUBPBS
IWORK( J ) = IWORK( J ) + IWORK( J-1 )
30 CONTINUE
*
* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
* using rank-1 modifications (cuts).
*
SPM1 = SUBPBS - 1
DO 40 I = 1, SPM1
SUBMAT = IWORK( I ) + 1
SMM1 = SUBMAT - 1
D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
40 CONTINUE
*
INDXQ = 4*N + 3
*
* Set up workspaces for eigenvalues only/accumulate new vectors
* routine
*
TEMP = LOG( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
* Initialize pointers
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
*
* Solve each submatrix eigenproblem at the bottom of the divide and
* conquer tree.
*
CURR = 0
DO 70 I = 0, SPM1
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 1 )
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+1 ) - IWORK( I )
END IF
LL = IQ - 1 + IWORK( IQPTR+CURR )
CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ RWORK( LL ), MATSIZ, RWORK, INFO )
CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
$ MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
$ RWORK( IWREM ) )
IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
CURR = CURR + 1
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
K = 1
DO 60 J = SUBMAT, IWORK( I+1 )
IWORK( INDXQ+J ) = K
K = K + 1
60 CONTINUE
70 CONTINUE
*
* Successively merge eigensystems of adjacent submatrices
* into eigensystem for the corresponding larger matrix.
*
* while ( SUBPBS > 1 )
*
CURLVL = 1
80 CONTINUE
IF( SUBPBS.GT.1 ) THEN
SPM2 = SUBPBS - 2
DO 90 I = 0, SPM2, 2
IF( I.EQ.0 ) THEN
SUBMAT = 1
MATSIZ = IWORK( 2 )
MSD2 = IWORK( 1 )
CURPRB = 0
ELSE
SUBMAT = IWORK( I ) + 1
MATSIZ = IWORK( I+2 ) - IWORK( I )
MSD2 = MATSIZ / 2
CURPRB = CURPRB + 1
END IF
*
* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
* into an eigensystem of size MATSIZ. ZLAED7 handles the case
* when the eigenvectors of a full or band Hermitian matrix (which
* was reduced to tridiagonal form) are desired.
*
* I am free to use Q as a valuable working space until Loop 150.
*
CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
$ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
$ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
$ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
$ IWORK( IPERM ), IWORK( IGIVPT ),
$ IWORK( IGIVCL ), RWORK( IGIVNM ),
$ Q( 1, SUBMAT ), RWORK( IWREM ),
$ IWORK( SUBPBS+1 ), INFO )
IF( INFO.GT.0 ) THEN
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
RETURN
END IF
IWORK( I / 2+1 ) = IWORK( I+2 )
90 CONTINUE
SUBPBS = SUBPBS / 2
CURLVL = CURLVL + 1
GO TO 80
END IF
*
* end while
*
* Re-merge the eigenvalues/vectors which were deflated at the final
* merge step.
*
DO 100 I = 1, N
J = IWORK( INDXQ+I )
RWORK( I ) = D( J )
CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( N, RWORK, 1, D, 1 )
*
RETURN
*
* End of ZLAED0
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlacrm.f 0000644 0000000 0000000 00000000132 14061636515 015314 x ustar 00 30 mtime=1623670093.342103952
30 atime=1623670093.342103952
30 ctime=1623670093.342103952
elk-7.2.42/src/LAPACK/zlacrm.f 0000644 0025044 0025044 00000011351 14061636515 017352 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLACRM multiplies a complex matrix by a square real matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACRM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION B( LDB, * ), RWORK( * )
* COMPLEX*16 A( LDA, * ), C( LDC, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACRM performs a very simple matrix-matrix multiplication:
*> C := A * B,
*> where A is M by N and complex; B is N by N and real;
*> C is M by N and complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A and of the matrix C.
*> M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns and rows of the matrix B and
*> the number of columns of the matrix C.
*> N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA, N)
*> On entry, A contains the M by N matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >=max(1,M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, N)
*> On entry, B contains the N by N matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >=max(1,N).
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC, N)
*> On exit, C contains the M by N matrix C.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >=max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array, dimension (2*M*N)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
*
* -- 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 ..
INTEGER LDA, LDB, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION B( LDB, * ), RWORK( * )
COMPLEX*16 A( LDA, * ), C( LDC, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. External Subroutines ..
EXTERNAL DGEMM
* ..
* .. Executable Statements ..
*
* Quick return if possible.
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
*
DO 20 J = 1, N
DO 10 I = 1, M
RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) )
10 CONTINUE
20 CONTINUE
*
L = M*N + 1
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 40 J = 1, N
DO 30 I = 1, M
C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
30 CONTINUE
40 CONTINUE
*
DO 60 J = 1, N
DO 50 I = 1, M
RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) )
50 CONTINUE
60 CONTINUE
CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
$ RWORK( L ), M )
DO 80 J = 1, N
DO 70 I = 1, M
C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
$ RWORK( L+( J-1 )*M+I-1 ) )
70 CONTINUE
80 CONTINUE
*
RETURN
*
* End of ZLACRM
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlarnv.f 0000644 0000000 0000000 00000000127 14061636515 015316 x ustar 00 29 mtime=1623670093.34410395
29 atime=1623670093.34410395
29 ctime=1623670093.34410395
elk-7.2.42/src/LAPACK/dlarnv.f 0000644 0025044 0025044 00000011262 14061636515 017351 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARNV returns a vector of random numbers from a uniform or normal distribution.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARNV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARNV( IDIST, ISEED, N, X )
*
* .. Scalar Arguments ..
* INTEGER IDIST, N
* ..
* .. Array Arguments ..
* INTEGER ISEED( 4 )
* DOUBLE PRECISION X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARNV returns a vector of n random real numbers from a uniform or
*> normal distribution.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IDIST
*> \verbatim
*> IDIST is INTEGER
*> Specifies the distribution of the random numbers:
*> = 1: uniform (0,1)
*> = 2: uniform (-1,1)
*> = 3: normal (0,1)
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*> ISEED is INTEGER array, dimension (4)
*> On entry, the seed of the random number generator; the array
*> elements must be between 0 and 4095, and ISEED(4) must be
*> odd.
*> On exit, the seed is updated.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of random numbers to be generated.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension (N)
*> The generated random numbers.
*> \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
*>
*> This routine calls the auxiliary routine DLARUV to generate random
*> real numbers from a uniform (0,1) distribution, in batches of up to
*> 128 using vectorisable code. The Box-Muller method is used to
*> transform numbers from a uniform to a normal distribution.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARNV( IDIST, ISEED, N, X )
*
* -- 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 ..
INTEGER IDIST, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
INTEGER LV
PARAMETER ( LV = 128 )
DOUBLE PRECISION TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IL2, IV
* ..
* .. Local Arrays ..
DOUBLE PRECISION U( LV )
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, MIN, SQRT
* ..
* .. External Subroutines ..
EXTERNAL DLARUV
* ..
* .. Executable Statements ..
*
DO 40 IV = 1, N, LV / 2
IL = MIN( LV / 2, N-IV+1 )
IF( IDIST.EQ.3 ) THEN
IL2 = 2*IL
ELSE
IL2 = IL
END IF
*
* Call DLARUV to generate IL2 numbers from a uniform (0,1)
* distribution (IL2 <= LV)
*
CALL DLARUV( ISEED, IL2, U )
*
IF( IDIST.EQ.1 ) THEN
*
* Copy generated numbers
*
DO 10 I = 1, IL
X( IV+I-1 ) = U( I )
10 CONTINUE
ELSE IF( IDIST.EQ.2 ) THEN
*
* Convert generated numbers to uniform (-1,1) distribution
*
DO 20 I = 1, IL
X( IV+I-1 ) = TWO*U( I ) - ONE
20 CONTINUE
ELSE IF( IDIST.EQ.3 ) THEN
*
* Convert generated numbers to normal (0,1) distribution
*
DO 30 I = 1, IL
X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
$ COS( TWOPI*U( 2*I ) )
30 CONTINUE
END IF
40 CONTINUE
RETURN
*
* End of DLARNV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlagtf.f 0000644 0000000 0000000 00000000132 14061636515 015265 x ustar 00 30 mtime=1623670093.346103948
30 atime=1623670093.345103949
30 ctime=1623670093.346103948
elk-7.2.42/src/LAPACK/dlagtf.f 0000644 0025044 0025044 00000020055 14061636515 017324 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAGTF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* DOUBLE PRECISION LAMBDA, TOL
* ..
* .. Array Arguments ..
* INTEGER IN( * )
* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
*> tridiagonal matrix and lambda is a scalar, as
*>
*> T - lambda*I = PLU,
*>
*> where P is a permutation matrix, L is a unit lower tridiagonal matrix
*> with at most one non-zero sub-diagonal elements per column and U is
*> an upper triangular matrix with at most two non-zero super-diagonal
*> elements per column.
*>
*> The factorization is obtained by Gaussian elimination with partial
*> pivoting and implicit row scaling.
*>
*> The parameter LAMBDA is included in the routine so that DLAGTF may
*> be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
*> inverse iteration.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (N)
*> On entry, A must contain the diagonal elements of T.
*>
*> On exit, A is overwritten by the n diagonal elements of the
*> upper triangular matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[in] LAMBDA
*> \verbatim
*> LAMBDA is DOUBLE PRECISION
*> On entry, the scalar lambda.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (N-1)
*> On entry, B must contain the (n-1) super-diagonal elements of
*> T.
*>
*> On exit, B is overwritten by the (n-1) super-diagonal
*> elements of the matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N-1)
*> On entry, C must contain the (n-1) sub-diagonal elements of
*> T.
*>
*> On exit, C is overwritten by the (n-1) sub-diagonal elements
*> of the matrix L of the factorization of T.
*> \endverbatim
*>
*> \param[in] TOL
*> \verbatim
*> TOL is DOUBLE PRECISION
*> On entry, a relative tolerance used to indicate whether or
*> not the matrix (T - lambda*I) is nearly singular. TOL should
*> normally be chose as approximately the largest relative error
*> in the elements of T. For example, if the elements of T are
*> correct to about 4 significant figures, then TOL should be
*> set to about 5*10**(-4). If TOL is supplied as less than eps,
*> where eps is the relative machine precision, then the value
*> eps is used in place of TOL.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N-2)
*> On exit, D is overwritten by the (n-2) second super-diagonal
*> elements of the matrix U of the factorization of T.
*> \endverbatim
*>
*> \param[out] IN
*> \verbatim
*> IN is INTEGER array, dimension (N)
*> On exit, IN contains details of the permutation matrix P. If
*> an interchange occurred at the kth step of the elimination,
*> then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
*> returns the smallest positive integer j such that
*>
*> abs( u(j,j) ) <= norm( (T - lambda*I)(j) )*TOL,
*>
*> where norm( A(j) ) denotes the sum of the absolute values of
*> the jth row of the matrix A. If no such j exists then IN(n)
*> is returned as zero. If IN(n) is returned as positive, then a
*> diagonal element of U is small, indicating that
*> (T - lambda*I) is singular or nearly singular,
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the kth 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
*
* =====================================================================
SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, 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
DOUBLE PRECISION LAMBDA, TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER K
DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLAGTF', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
A( 1 ) = A( 1 ) - LAMBDA
IN( N ) = 0
IF( N.EQ.1 ) THEN
IF( A( 1 ).EQ.ZERO )
$ IN( 1 ) = 1
RETURN
END IF
*
EPS = DLAMCH( 'Epsilon' )
*
TL = MAX( TOL, EPS )
SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
DO 10 K = 1, N - 1
A( K+1 ) = A( K+1 ) - LAMBDA
SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
IF( K.LT.( N-1 ) )
$ SCALE2 = SCALE2 + ABS( B( K+1 ) )
IF( A( K ).EQ.ZERO ) THEN
PIV1 = ZERO
ELSE
PIV1 = ABS( A( K ) ) / SCALE1
END IF
IF( C( K ).EQ.ZERO ) THEN
IN( K ) = 0
PIV2 = ZERO
SCALE1 = SCALE2
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
PIV2 = ABS( C( K ) ) / SCALE2
IF( PIV2.LE.PIV1 ) THEN
IN( K ) = 0
SCALE1 = SCALE2
C( K ) = C( K ) / A( K )
A( K+1 ) = A( K+1 ) - C( K )*B( K )
IF( K.LT.( N-1 ) )
$ D( K ) = ZERO
ELSE
IN( K ) = 1
MULT = A( K ) / C( K )
A( K ) = C( K )
TEMP = A( K+1 )
A( K+1 ) = B( K ) - MULT*TEMP
IF( K.LT.( N-1 ) ) THEN
D( K ) = B( K+1 )
B( K+1 ) = -MULT*D( K )
END IF
B( K ) = TEMP
C( K ) = MULT
END IF
END IF
IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = K
10 CONTINUE
IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
$ IN( N ) = N
*
RETURN
*
* End of DLAGTF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlagts.f 0000644 0000000 0000000 00000000132 14061636515 015302 x ustar 00 30 mtime=1623670093.348103946
30 atime=1623670093.347103947
30 ctime=1623670093.348103946
elk-7.2.42/src/LAPACK/dlagts.f 0000644 0025044 0025044 00000030313 14061636515 017337 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAGTS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, JOB, N
* DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
* INTEGER IN( * )
* DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAGTS may be used to solve one of the systems of equations
*>
*> (T - lambda*I)*x = y or (T - lambda*I)**T*x = y,
*>
*> where T is an n by n tridiagonal matrix, for x, following the
*> factorization of (T - lambda*I) as
*>
*> (T - lambda*I) = P*L*U ,
*>
*> by routine DLAGTF. The choice of equation to be solved is
*> controlled by the argument JOB, and in each case there is an option
*> to perturb zero or very small diagonal elements of U, this option
*> being intended for use in applications such as inverse iteration.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] JOB
*> \verbatim
*> JOB is INTEGER
*> Specifies the job to be performed by DLAGTS as follows:
*> = 1: The equations (T - lambda*I)x = y are to be solved,
*> but diagonal elements of U are not to be perturbed.
*> = -1: The equations (T - lambda*I)x = y are to be solved
*> and, if overflow would otherwise occur, the diagonal
*> elements of U are to be perturbed. See argument TOL
*> below.
*> = 2: The equations (T - lambda*I)**Tx = y are to be solved,
*> but diagonal elements of U are not to be perturbed.
*> = -2: The equations (T - lambda*I)**Tx = y are to be solved
*> and, if overflow would otherwise occur, the diagonal
*> elements of U are to be perturbed. See argument TOL
*> below.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (N)
*> On entry, A must contain the diagonal elements of U as
*> returned from DLAGTF.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (N-1)
*> On entry, B must contain the first super-diagonal elements of
*> U as returned from DLAGTF.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (N-1)
*> On entry, C must contain the sub-diagonal elements of L as
*> returned from DLAGTF.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N-2)
*> On entry, D must contain the second super-diagonal elements
*> of U as returned from DLAGTF.
*> \endverbatim
*>
*> \param[in] IN
*> \verbatim
*> IN is INTEGER array, dimension (N)
*> On entry, IN must contain details of the matrix P as returned
*> from DLAGTF.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is DOUBLE PRECISION array, dimension (N)
*> On entry, the right hand side vector y.
*> On exit, Y is overwritten by the solution vector x.
*> \endverbatim
*>
*> \param[in,out] TOL
*> \verbatim
*> TOL is DOUBLE PRECISION
*> On entry, with JOB < 0, TOL should be the minimum
*> perturbation to be made to very small diagonal elements of U.
*> TOL should normally be chosen as about eps*norm(U), where eps
*> is the relative machine precision, but if TOL is supplied as
*> non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
*> If JOB > 0 then TOL is not referenced.
*>
*> On exit, TOL is changed as described above, only if TOL is
*> non-positive on entry. Otherwise TOL is unchanged.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> > 0: overflow would occur when computing the INFO(th)
*> element of the solution vector x. This can only occur
*> when JOB is supplied as positive and either means
*> that a diagonal element of U is very small, or that
*> the elements of the right-hand side vector y are very
*> large.
*> \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 DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, 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..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER INFO, JOB, N
DOUBLE PRECISION TOL
* ..
* .. Array Arguments ..
INTEGER IN( * )
DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER K
DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
INFO = 0
IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLAGTS', -INFO )
RETURN
END IF
*
IF( N.EQ.0 )
$ RETURN
*
EPS = DLAMCH( 'Epsilon' )
SFMIN = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SFMIN
*
IF( JOB.LT.0 ) THEN
IF( TOL.LE.ZERO ) THEN
TOL = ABS( A( 1 ) )
IF( N.GT.1 )
$ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
DO 10 K = 3, N
TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
$ ABS( D( K-2 ) ) )
10 CONTINUE
TOL = TOL*EPS
IF( TOL.EQ.ZERO )
$ TOL = EPS
END IF
END IF
*
IF( ABS( JOB ).EQ.1 ) THEN
DO 20 K = 2, N
IF( IN( K-1 ).EQ.0 ) THEN
Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
20 CONTINUE
IF( JOB.EQ.1 ) THEN
DO 30 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
30 CONTINUE
ELSE
DO 50 K = N, 1, -1
IF( K.LE.N-2 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
ELSE IF( K.EQ.N-1 ) THEN
TEMP = Y( K ) - B( K )*Y( K+1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
40 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 40
END IF
END IF
Y( K ) = TEMP / AK
50 CONTINUE
END IF
ELSE
*
* Come to here if JOB = 2 or -2
*
IF( JOB.EQ.2 ) THEN
DO 60 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
INFO = K
RETURN
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
INFO = K
RETURN
END IF
END IF
Y( K ) = TEMP / AK
60 CONTINUE
ELSE
DO 80 K = 1, N
IF( K.GE.3 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
ELSE IF( K.EQ.2 ) THEN
TEMP = Y( K ) - B( K-1 )*Y( K-1 )
ELSE
TEMP = Y( K )
END IF
AK = A( K )
PERT = SIGN( TOL, AK )
70 CONTINUE
ABSAK = ABS( AK )
IF( ABSAK.LT.ONE ) THEN
IF( ABSAK.LT.SFMIN ) THEN
IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
$ THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
ELSE
TEMP = TEMP*BIGNUM
AK = AK*BIGNUM
END IF
ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
AK = AK + PERT
PERT = 2*PERT
GO TO 70
END IF
END IF
Y( K ) = TEMP / AK
80 CONTINUE
END IF
*
DO 90 K = N, 2, -1
IF( IN( K-1 ).EQ.0 ) THEN
Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
ELSE
TEMP = Y( K-1 )
Y( K-1 ) = Y( K )
Y( K ) = TEMP - C( K-1 )*Y( K )
END IF
90 CONTINUE
END IF
*
* End of DLAGTS
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlatrs.f 0000644 0000000 0000000 00000000132 14061636515 015343 x ustar 00 30 mtime=1623670093.350103945
30 atime=1623670093.350103945
30 ctime=1623670093.350103945
elk-7.2.42/src/LAPACK/zlatrs.f 0000644 0025044 0025044 00000072535 14061636515 017414 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLATRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
* CNORM, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORMIN, TRANS, UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* DOUBLE PRECISION CNORM( * )
* COMPLEX*16 A( LDA, * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLATRS solves one of the triangular systems
*>
*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
*>
*> with scaling to prevent overflow. Here A is an upper or lower
*> triangular matrix, A**T denotes the transpose of A, A**H denotes the
*> conjugate transpose of A, x and b are n-element vectors, and s is a
*> scaling factor, usually less than or equal to 1, chosen so that the
*> components of x will be less than the overflow threshold. If the
*> unscaled problem will not cause overflow, the Level 2 BLAS routine
*> ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
*> then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower triangular.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the operation applied to A.
*> = 'N': Solve A * x = s*b (No transpose)
*> = 'T': Solve A**T * x = s*b (Transpose)
*> = 'C': Solve A**H * x = s*b (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A is unit triangular.
*> = 'N': Non-unit triangular
*> = 'U': Unit triangular
*> \endverbatim
*>
*> \param[in] NORMIN
*> \verbatim
*> NORMIN is CHARACTER*1
*> Specifies whether CNORM has been set or not.
*> = 'Y': CNORM contains the column norms on entry
*> = 'N': CNORM is not set on entry. On exit, the norms will
*> be computed and stored in CNORM.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The triangular matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of the array A contains the upper
*> triangular matrix, and the strictly lower triangular part of
*> A is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of the array A contains the lower triangular
*> matrix, and the strictly upper triangular part of A is not
*> referenced. If DIAG = 'U', the diagonal elements of A are
*> also not referenced and are assumed to be 1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max (1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension (N)
*> On entry, the right hand side b of the triangular system.
*> On exit, X is overwritten by the solution vector x.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> The scaling factor s for the triangular system
*> A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
*> If SCALE = 0, the matrix A is singular or badly scaled, and
*> the vector x is an exact or approximate solution to A*x = 0.
*> \endverbatim
*>
*> \param[in,out] CNORM
*> \verbatim
*> CNORM is DOUBLE PRECISION array, dimension (N)
*>
*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
*> contains the norm of the off-diagonal part of the j-th column
*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal
*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
*> must be greater than or equal to the 1-norm.
*>
*> If NORMIN = 'N', CNORM is an output argument and CNORM(j)
*> returns the 1-norm of the offdiagonal part of the j-th column
*> of A.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A rough bound on x is computed; if that is less than overflow, ZTRSV
*> is called, otherwise, specific code is used which checks for possible
*> overflow or divide-by-zero at every operation.
*>
*> A columnwise scheme is used for solving A*x = b. The basic algorithm
*> if A is lower triangular is
*>
*> x[1:n] := b[1:n]
*> for j = 1, ..., n
*> x(j) := x(j) / A(j,j)
*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
*> end
*>
*> Define bounds on the components of x after j iterations of the loop:
*> M(j) = bound on x[1:j]
*> G(j) = bound on x[j+1:n]
*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*>
*> Then for iteration j+1 we have
*> M(j+1) <= G(j) / | A(j+1,j+1) |
*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*>
*> where CNORM(j+1) is greater than or equal to the infinity-norm of
*> column j+1 of A, not counting the diagonal. Hence
*>
*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
*> 1<=i<=j
*> and
*>
*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*> 1<=i< j
*>
*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the
*> reciprocal of the largest M(j), j=1,..,n, is larger than
*> max(underflow, 1/overflow).
*>
*> The bound on x(j) is also used to determine when a step in the
*> columnwise method can be performed without fear of overflow. If
*> the computed bound is greater than a large constant, x is scaled to
*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*>
*> Similarly, a row-wise scheme is used to solve A**T *x = b or
*> A**H *x = b. The basic algorithm for A upper triangular is
*>
*> for j = 1, ..., n
*> x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
*> end
*>
*> We simultaneously compute two bounds
*> G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
*> M(j) = bound on x(i), 1<=i<=j
*>
*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
*> Then the bound on x(j) is
*>
*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*>
*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
*> 1<=i<=j
*>
*> and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater
*> than max(underflow, 1/overflow).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine (version 3.8.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION CNORM( * )
COMPLEX*16 A( LDA, * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
$ TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
$ XBND, XJ, XMAX
COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX, IZAMAX
DOUBLE PRECISION DLAMCH, DZASUM
COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC,
$ ZDOTU, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV, DLABAD
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1, CABS2
* ..
* .. Statement Function definitions ..
CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) +
$ ABS( DIMAG( ZDUM ) / 2.D0 )
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLATRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' )
BIGNUM = ONE / SMLNUM
CALL DLABAD( SMLNUM, BIGNUM )
SMLNUM = SMLNUM / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
SCALE = ONE
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N - 1
CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 )
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM/2.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM*HALF ) THEN
TSCAL = ONE
ELSE
TSCAL = HALF / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine ZTRSV can be used.
*
XMAX = ZERO
DO 30 J = 1, N
XMAX = MAX( XMAX, CABS2( X( J ) ) )
30 CONTINUE
XBND = XMAX
*
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 60
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = HALF / MAX( XBND, SMLNUM )
XBND = GROW
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 60
*
TJJS = A( J, J )
TJJ = CABS1( TJJS )
*
IF( TJJ.GE.SMLNUM ) THEN
*
* M(j) = G(j-1) / abs(A(j,j))
*
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
ELSE
*
* M(j) could overflow, set XBND to 0.
*
XBND = ZERO
END IF
*
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
40 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
DO 50 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 60
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
50 CONTINUE
END IF
60 CONTINUE
*
ELSE
*
* Compute the growth in A**T * x = b or A**H * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 90
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = HALF / MAX( XBND, SMLNUM )
XBND = GROW
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 90
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
TJJS = A( J, J )
TJJ = CABS1( TJJS )
*
IF( TJJ.GE.SMLNUM ) THEN
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
ELSE
*
* M(j) could overflow, set XBND to 0.
*
XBND = ZERO
END IF
70 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
DO 80 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 90
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
80 CONTINUE
END IF
90 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM*HALF ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = ( BIGNUM*HALF ) / XMAX
CALL ZDSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
ELSE
XMAX = XMAX*TWO
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 120 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 110
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
XJ = CABS1( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
XJ = CABS1( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 100 I = 1, N
X( I ) = ZERO
100 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
110 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL ZDSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
$ 1 )
I = IZAMAX( J-1, X, 1 )
XMAX = CABS1( X( I ) )
END IF
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
$ X( J+1 ), 1 )
I = J + IZAMAX( N-J, X( J+1 ), 1 )
XMAX = CABS1( X( I ) )
END IF
END IF
120 CONTINUE
*
ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
* Solve A**T * x = b
*
DO 170 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = CABS1( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = ZLADIV( USCAL, TJJS )
END IF
IF( REC.LT.ONE ) THEN
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
CSUMJ = ZERO
IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call ZDOTU to perform the dot product.
*
IF( UPPER ) THEN
CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 130 I = 1, J - 1
CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
130 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 140 I = J + 1, N
CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
140 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
*
* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - CSUMJ
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 160
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0 and compute a solution to A**T *x = 0.
*
DO 150 I = 1, N
X( I ) = ZERO
150 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
160 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
END IF
XMAX = MAX( XMAX, CABS1( X( J ) ) )
170 CONTINUE
*
ELSE
*
* Solve A**H * x = b
*
DO 220 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = CABS1( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = DCONJG( A( J, J ) )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = CABS1( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = ZLADIV( USCAL, TJJS )
END IF
IF( REC.LT.ONE ) THEN
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
CSUMJ = ZERO
IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call ZDOTC to perform the dot product.
*
IF( UPPER ) THEN
CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 180 I = 1, J - 1
CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
$ X( I )
180 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 190 I = J + 1, N
CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
$ X( I )
190 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
*
* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - CSUMJ
XJ = CABS1( X( J ) )
IF( NOUNIT ) THEN
TJJS = DCONJG( A( J, J ) )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 210
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = CABS1( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL ZDSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = ZLADIV( X( J ), TJJS )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0 and compute a solution to A**H *x = 0.
*
DO 200 I = 1, N
X( I ) = ZERO
200 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
210 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
END IF
XMAX = MAX( XMAX, CABS1( X( J ) ) )
220 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of ZLATRS
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ztrti2.f 0000644 0000000 0000000 00000000132 14061636515 015262 x ustar 00 30 mtime=1623670093.352103943
30 atime=1623670093.352103943
30 ctime=1623670093.352103943
elk-7.2.42/src/LAPACK/ztrti2.f 0000644 0025044 0025044 00000013437 14061636515 017327 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTRTI2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, UPLO
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTRTI2 computes the inverse of a complex upper or lower triangular
*> matrix.
*>
*> This is the Level 2 BLAS version of the algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower triangular.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A is unit triangular.
*> = 'N': Non-unit triangular
*> = 'U': Unit triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the triangular matrix A. If UPLO = 'U', the
*> leading n by n upper triangular part of the array A contains
*> the upper triangular matrix, and the strictly lower
*> triangular part of A is not referenced. If UPLO = 'L', the
*> leading n by n lower triangular part of the array A contains
*> the lower triangular matrix, and the strictly upper
*> triangular part of A is not referenced. If DIAG = 'U', the
*> diagonal elements of A are also not referenced and are
*> assumed to be 1.
*>
*> On exit, the (triangular) inverse of the original matrix, in
*> the same storage format.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, 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 DIAG, UPLO
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL NOUNIT, UPPER
INTEGER J
COMPLEX*16 AJJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZSCAL, ZTRMV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOUNIT = LSAME( DIAG, 'N' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTRTI2', -INFO )
RETURN
END IF
*
IF( UPPER ) THEN
*
* Compute inverse of upper triangular matrix.
*
DO 10 J = 1, N
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
*
* Compute elements 1:j-1 of j-th column.
*
CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
$ A( 1, J ), 1 )
CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* Compute inverse of lower triangular matrix.
*
DO 20 J = N, 1, -1
IF( NOUNIT ) THEN
A( J, J ) = ONE / A( J, J )
AJJ = -A( J, J )
ELSE
AJJ = -ONE
END IF
IF( J.LT.N ) THEN
*
* Compute elements j+1:n of j-th column.
*
CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J,
$ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 )
END IF
20 CONTINUE
END IF
*
RETURN
*
* End of ZTRTI2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zungl2.f 0000644 0000000 0000000 00000000132 14061636515 015245 x ustar 00 30 mtime=1623670093.354103941
30 atime=1623670093.354103941
30 ctime=1623670093.354103941
elk-7.2.42/src/LAPACK/zungl2.f 0000644 0025044 0025044 00000012645 14061636515 017312 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGL2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
*> which is defined as the first m rows of a product of k elementary
*> reflectors of order n
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th row must contain the vector which defines
*> the elementary reflector H(i), for i = 1,2,...,k, as returned
*> by ZGELQF in the first k rows of its array argument A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, 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 ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGL2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows k+1:m to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = K + 1, M
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.K .AND. J.LE.M )
$ A( J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = K, 1, -1
*
* Apply H(i)**H to A(i:m,i:n) from the right
*
IF( I.LT.N ) THEN
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
IF( I.LT.M ) THEN
A( I, I ) = ONE
CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
$ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
END IF
CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
CALL ZLACGV( N-I, A( I, I+1 ), LDA )
END IF
A( I, I ) = ONE - DCONJG( TAU( I ) )
*
* Set A(i,1:i-1) to zero
*
DO 30 L = 1, I - 1
A( I, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNGL2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zung2r.f 0000644 0000000 0000000 00000000131 14061636515 015252 x ustar 00 30 mtime=1623670093.356103939
29 atime=1623670093.35510394
30 ctime=1623670093.356103939
elk-7.2.42/src/LAPACK/zung2r.f 0000644 0025044 0025044 00000012100 14061636515 017302 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNG2R
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNG2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
*> which is defined as the first n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQRF in the first k columns of its array
*> argument A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, 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 ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2R
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zungql.f 0000644 0000000 0000000 00000000132 14061636515 015344 x ustar 00 30 mtime=1623670093.358103937
30 atime=1623670093.357103938
30 ctime=1623670093.358103937
elk-7.2.42/src/LAPACK/zungql.f 0000644 0025044 0025044 00000020006 14061636515 017377 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNGQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNGQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
*> which is defined as the last N columns of a product of K elementary
*> reflectors of order M
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQLF in the last k columns of its array
*> argument A.
*> On exit, the M-by-N matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N).
*> For optimum performance LWORK >= N*NB, where NB is the
*> optimal blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, 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, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LQUERY
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
$ NB, NBMIN, NX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LQUERY = ( LWORK.EQ.-1 )
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
*
IF( INFO.EQ.0 ) THEN
IF( N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 )
LWKOPT = N*NB
END IF
WORK( 1 ) = LWKOPT
*
IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
INFO = -8
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNGQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
RETURN
END IF
*
NBMIN = 2
NX = 0
IWS = N
IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
* Determine when to cross over from blocked to unblocked code.
*
NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) )
IF( NX.LT.K ) THEN
*
* Determine if workspace is large enough for blocked code.
*
LDWORK = N
IWS = LDWORK*NB
IF( LWORK.LT.IWS ) THEN
*
* Not enough workspace to use optimal NB: reduce NB and
* determine the minimum value of NB.
*
NB = LWORK / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) )
END IF
END IF
END IF
*
IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
* Use blocked code after the first block.
* The last kk columns are handled by the block method.
*
KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
*
* Set A(m-kk+1:m,1:n-kk) to zero.
*
DO 20 J = 1, N - KK
DO 10 I = M - KK + 1, M
A( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
KK = 0
END IF
*
* Use unblocked code for the first or only block.
*
CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
*
IF( KK.GT.0 ) THEN
*
* Use blocked code
*
DO 50 I = K - KK + 1, K, NB
IB = MIN( NB, K-I+1 )
IF( N-K+I.GT.1 ) THEN
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
$ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
*
CALL ZLARFB( 'Left', 'No transpose', 'Backward',
$ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
$ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
$ WORK( IB+1 ), LDWORK )
END IF
*
* Apply H to rows 1:m-k+i+ib-1 of current block
*
CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
$ TAU( I ), WORK, IINFO )
*
* Set rows m-k+i+ib:m of current block to zero
*
DO 40 J = N - K + I, N - K + I + IB - 1
DO 30 L = M - K + I + IB, M
A( L, J ) = ZERO
30 CONTINUE
40 CONTINUE
50 CONTINUE
END IF
*
WORK( 1 ) = IWS
RETURN
*
* End of ZUNGQL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmqr.f 0000644 0000000 0000000 00000000132 14061636515 015360 x ustar 00 30 mtime=1623670093.359103936
30 atime=1623670093.359103936
30 ctime=1623670093.359103936
elk-7.2.42/src/LAPACK/zunmqr.f 0000644 0025044 0025044 00000022231 14061636515 017415 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMQR overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Conjugate transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQRF in the first k columns of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For 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.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB + TSIZE
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IF( LWORK.LT.NW*NB+TSIZE ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IWT = 1 + NW*NB
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
$ IB, A( I, I ), LDA, WORK( IWT ), LDT,
$ C( IC, JC ), LDC, WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmlq.f 0000644 0000000 0000000 00000000132 14061636515 015352 x ustar 00 30 mtime=1623670093.361103934
30 atime=1623670093.361103934
30 ctime=1623670093.361103934
elk-7.2.42/src/LAPACK/zunmlq.f 0000644 0025044 0025044 00000022503 14061636515 017411 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMLQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMLQ + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMLQ overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Conjugate transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L',
*> (LDA,N) if SIDE = 'R'
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGELQF in the first k rows of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,K).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For 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.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
CHARACTER TRANST
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB + TSIZE
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMLQ', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IF( LWORK.LT.NW*NB+TSIZE ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IWT = 1 + NW*NB
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
IF( NOTRAN ) THEN
TRANST = 'C'
ELSE
TRANST = 'N'
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i) H(i+1) . . . H(i+ib-1)
*
CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
$ A( I, I ), LDA, WORK( IWT ), LDT,
$ C( IC, JC ), LDC, WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMLQ
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmql.f 0000644 0000000 0000000 00000000132 14061636515 015352 x ustar 00 30 mtime=1623670093.363103932
30 atime=1623670093.363103932
30 ctime=1623670093.363103932
elk-7.2.42/src/LAPACK/zunmql.f 0000644 0025044 0025044 00000022253 14061636515 017413 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMQL overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'C': Transpose, apply Q**H.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQLF in the last k columns of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For good performance, LWORK should genreally 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.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = MAX( 1, N )
ELSE
NQ = N
NW = MAX( 1, M )
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
LWKOPT = 1
ELSE
NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB + TSIZE
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IF( LWORK.LT.NW*NB+TSIZE ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
$ IINFO )
ELSE
*
* Use blocked code
*
IWT = 1 + NW*NB
IF( ( LEFT .AND. NOTRAN ) .OR.
$ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = NB
ELSE
I1 = ( ( K-1 ) / NB )*NB + 1
I2 = 1
I3 = -NB
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IB = MIN( NB, K-I+1 )
*
* Form the triangular factor of the block reflector
* H = H(i+ib-1) . . . H(i+1) H(i)
*
CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**H is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H**H is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H**H
*
CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
$ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMQL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zung2l.f 0000644 0000000 0000000 00000000132 14061636515 015245 x ustar 00 30 mtime=1623670093.365103931
30 atime=1623670093.365103931
30 ctime=1623670093.365103931
elk-7.2.42/src/LAPACK/zung2l.f 0000644 0025044 0025044 00000012250 14061636515 017302 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNG2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
*> which is defined as the last n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by ZGEQLF in the last k columns of its array
*> argument A.
*> On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, 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 ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2L
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlarf.f 0000644 0000000 0000000 00000000132 14061636515 015142 x ustar 00 30 mtime=1623670093.367103929
30 atime=1623670093.367103929
30 ctime=1623670093.367103929
elk-7.2.42/src/LAPACK/zlarf.f 0000644 0025044 0025044 00000014267 14061636515 017211 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLARF applies an elementary reflector to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* COMPLEX*16 TAU
* ..
* .. Array Arguments ..
* COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARF applies a complex elementary reflector H to a complex M-by-N
*> matrix C, from either the left or the right. H is represented in the
*> form
*>
*> H = I - tau * v * v**H
*>
*> where tau is a complex scalar and v is a complex vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*>
*> To apply H**H, supply conjg(tau) instead
*> tau.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is COMPLEX*16 array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- 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 SIDE
INTEGER INCV, LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAZLR, ILAZLC
EXTERNAL LSAME, ILAZLR, ILAZLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
* Set up variables for scanning V. LASTV begins pointing to the end
* of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
* Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
* Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILAZLC(LASTV, N, C, LDC)
ELSE
* Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILAZLR(M, LASTV, C, LDC)
END IF
END IF
* Note that lastc.eq.0 renders the BLAS operations null; no special
* case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
*
CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
$ C, LDC, V, INCV, ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
*
CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
*
CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of ZLARF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed2.f 0000644 0000000 0000000 00000000132 14061636515 015157 x ustar 00 30 mtime=1623670093.369103927
30 atime=1623670093.369103927
30 ctime=1623670093.369103927
elk-7.2.42/src/LAPACK/dlaed2.f 0000644 0025044 0025044 00000037231 14061636515 017222 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED2 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 DLAED2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED2( 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
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
* $ INDXQ( * )
* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
* $ W( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED2 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 DOUBLE PRECISION array, dimension (N)
*> On entry, D contains the eigenvalues of the two submatrices to
*> be combined.
*> On exit, D contains the trailing (N-K) updated eigenvalues
*> (those which were deflated) sorted into increasing order.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is DOUBLE PRECISION 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 DOUBLE PRECISION
*> 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
*> DLAED3.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
*> A copy of the first K eigenvalues which will be used by
*> DLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> The first k values of the final deflation-altered z-vector
*> which will be passed to DLAED3.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
*> A copy of the first K eigenvectors which will be used by
*> DLAED3 in a matrix multiply (DGEMM) 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 DLAED2( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
$ INDXQ( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ W( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Arrays ..
INTEGER CTOT( 4 ), PSM( 4 )
* ..
* .. Local Scalars ..
INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
$ N2, NJ, PJ
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, 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( 'DLAED2', -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 DSCAL( 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 DSCAL( 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 DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
DO 30 I = 1, N
INDX( I ) = INDXQ( INDXC( I ) )
30 CONTINUE
*
* Calculate the allowable deflation tolerance
*
IMAX = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( '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 DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
DLAMDA( J ) = D( I )
IQ2 = IQ2 + N
40 CONTINUE
CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
CALL DCOPY( 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 = DLAPY2( 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 DROT( 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 DCOPY( 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 DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
CALL DCOPY( 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 DCOPY( 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 DCOPY( 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 DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N,
$ Q( 1, K+1 ), LDQ )
CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
END IF
*
* Copy CTOT into COLTYP for referencing in DLAED3.
*
DO 180 J = 1, 4
COLTYP( J ) = CTOT( J )
180 CONTINUE
*
190 CONTINUE
RETURN
*
* End of DLAED2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaruv.f 0000644 0000000 0000000 00000000132 14061636515 015321 x ustar 00 30 mtime=1623670093.371103925
30 atime=1623670093.371103925
30 ctime=1623670093.371103925
elk-7.2.42/src/LAPACK/dlaruv.f 0000644 0025044 0025044 00000044072 14061636515 017365 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARUV returns a vector of n random real numbers from a uniform distribution.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARUV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARUV( ISEED, N, X )
*
* .. Scalar Arguments ..
* INTEGER N
* ..
* .. Array Arguments ..
* INTEGER ISEED( 4 )
* DOUBLE PRECISION X( N )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARUV returns a vector of n random real numbers from a uniform (0,1)
*> distribution (n <= 128).
*>
*> This is an auxiliary routine called by DLARNV and ZLARNV.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in,out] ISEED
*> \verbatim
*> ISEED is INTEGER array, dimension (4)
*> On entry, the seed of the random number generator; the array
*> elements must be between 0 and 4095, and ISEED(4) must be
*> odd.
*> On exit, the seed is updated.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of random numbers to be generated. N <= 128.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension (N)
*> The generated random numbers.
*> \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
*>
*> This routine uses a multiplicative congruential method with modulus
*> 2**48 and multiplier 33952834046453 (see G.S.Fishman,
*> 'Multiplicative congruential random number generators with modulus
*> 2**b: an exhaustive analysis for b = 32 and a partial analysis for
*> b = 48', Math. Comp. 189, pp 331-344, 1990).
*>
*> 48-bit integers are stored in 4 integer array elements with 12 bits
*> per element. Hence the routine is portable across machines with
*> integers of 32 bits or more.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARUV( ISEED, N, X )
*
* -- 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 ..
INTEGER N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
DOUBLE PRECISION X( N )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
INTEGER LV, IPW2
DOUBLE PRECISION R
PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
* ..
* .. Local Arrays ..
INTEGER MM( LV, 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, MIN, MOD
* ..
* .. Data statements ..
DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
$ 2549 /
DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
$ 1145 /
DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
$ 2253 /
DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
$ 305 /
DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
$ 3301 /
DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
$ 1065 /
DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
$ 3133 /
DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
$ 2913 /
DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
$ 3285 /
DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
$ 1241 /
DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
$ 1197 /
DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
$ 3729 /
DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
$ 2501 /
DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
$ 1673 /
DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
$ 541 /
DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
$ 2753 /
DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
$ 949 /
DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
$ 2361 /
DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
$ 1165 /
DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
$ 4081 /
DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
$ 2725 /
DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
$ 3305 /
DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
$ 3069 /
DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
$ 3617 /
DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
$ 3733 /
DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
$ 409 /
DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
$ 2157 /
DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
$ 1361 /
DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
$ 3973 /
DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
$ 1865 /
DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
$ 2525 /
DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
$ 1409 /
DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
$ 3445 /
DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
$ 3577 /
DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
$ 77 /
DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
$ 3761 /
DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
$ 2149 /
DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
$ 1449 /
DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
$ 3005 /
DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
$ 225 /
DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
$ 85 /
DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
$ 3673 /
DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
$ 3117 /
DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
$ 3089 /
DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
$ 1349 /
DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
$ 2057 /
DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
$ 413 /
DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
$ 65 /
DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
$ 1845 /
DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
$ 697 /
DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
$ 3085 /
DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
$ 3441 /
DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
$ 1573 /
DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
$ 3689 /
DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
$ 2941 /
DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
$ 929 /
DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
$ 533 /
DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
$ 2841 /
DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
$ 4077 /
DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
$ 721 /
DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
$ 2821 /
DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
$ 2249 /
DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
$ 2397 /
DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
$ 2817 /
DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
$ 245 /
DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
$ 1913 /
DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
$ 1997 /
DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
$ 3121 /
DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
$ 997 /
DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
$ 1833 /
DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
$ 2877 /
DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
$ 1633 /
DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
$ 981 /
DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
$ 2009 /
DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
$ 941 /
DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
$ 2449 /
DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
$ 197 /
DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
$ 2441 /
DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
$ 285 /
DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
$ 1473 /
DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
$ 2741 /
DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
$ 3129 /
DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
$ 909 /
DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
$ 2801 /
DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
$ 421 /
DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
$ 4073 /
DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
$ 2813 /
DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
$ 2337 /
DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
$ 1429 /
DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
$ 1177 /
DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
$ 1901 /
DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
$ 81 /
DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
$ 1669 /
DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
$ 2633 /
DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
$ 2269 /
DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
$ 129 /
DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
$ 1141 /
DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
$ 249 /
DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
$ 3917 /
DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
$ 2481 /
DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
$ 3941 /
DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
$ 2217 /
DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
$ 2749 /
DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
$ 3041 /
DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
$ 1877 /
DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
$ 345 /
DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
$ 2861 /
DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
$ 1809 /
DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
$ 3141 /
DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
$ 2825 /
DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
$ 157 /
DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
$ 2881 /
DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
$ 3637 /
DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
$ 1465 /
DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
$ 2829 /
DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
$ 2161 /
DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
$ 3365 /
DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
$ 361 /
DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
$ 2685 /
DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
$ 3745 /
DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
$ 2325 /
DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
$ 3609 /
DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
$ 3821 /
DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
$ 3537 /
DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
$ 517 /
DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
$ 3017 /
DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
$ 2141 /
DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
$ 1537 /
* ..
* .. Executable Statements ..
*
I1 = ISEED( 1 )
I2 = ISEED( 2 )
I3 = ISEED( 3 )
I4 = ISEED( 4 )
*
DO 10 I = 1, MIN( N, LV )
*
20 CONTINUE
*
* Multiply the seed by i-th power of the multiplier modulo 2**48
*
IT4 = I4*MM( I, 4 )
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
$ I4*MM( I, 1 )
IT1 = MOD( IT1, IPW2 )
*
* Convert 48-bit integer to a real number in the interval (0,1)
*
X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
$ DBLE( IT4 ) ) ) )
*
IF (X( I ).EQ.1.0D0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then X( I ) will
* be rounded to exactly 1.0.
* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case X( I ) = 0.0 should not be possible.
I1 = I1 + 2
I2 = I2 + 2
I3 = I3 + 2
I4 = I4 + 2
GOTO 20
END IF
*
10 CONTINUE
*
* Return final value of seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* End of DLARUV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq2.f 0000644 0000000 0000000 00000000132 14061636515 015212 x ustar 00 30 mtime=1623670093.374103922
30 atime=1623670093.373103923
30 ctime=1623670093.374103922
elk-7.2.42/src/LAPACK/dlasq2.f 0000644 0025044 0025044 00000041167 14061636515 017260 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ2( N, Z, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ2 computes all the eigenvalues of the symmetric positive
*> definite tridiagonal matrix associated with the qd array Z to high
*> relative accuracy are computed to high relative accuracy, in the
*> absence of denormalization, underflow and overflow.
*>
*> To see the relation of Z to the tridiagonal matrix, let L be a
*> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
*> let U be an upper bidiagonal matrix with 1's above and diagonal
*> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
*> symmetric tridiagonal to which it is similar.
*>
*> Note : DLASQ2 defines a logical variable, IEEE, which is true
*> on machines which follow ieee-754 floating-point standard in their
*> handling of infinities and NaNs, and false otherwise. This variable
*> is passed to DLASQ3.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of rows and columns in the matrix. N >= 0.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( 4*N )
*> On entry Z holds the qd array. On exit, entries 1 to N hold
*> the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
*> trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
*> N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
*> holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
*> shifts that failed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if the i-th argument is a scalar and had an illegal
*> value, then INFO = -i, if the i-th argument is an
*> array and the j-entry had an illegal value, then
*> INFO = -(i*100+j)
*> > 0: the algorithm failed
*> = 1, a split was marked by a positive value in E
*> = 2, current block of Z not diagonalized after 100*N
*> iterations (in inner while loop). On exit Z holds
*> a qd array with the same eigenvalues as the given Z.
*> = 3, termination criterion of outer while loop not met
*> (program created more than N unreduced blocks)
*> \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
*>
*> Local Variables: I0:N0 defines a current unreduced segment of Z.
*> The shifts are accumulated in SIGMA. Iteration count is in ITER.
*> Ping-pong is controlled by PP (alternates between 0 and 1).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASQ2( N, Z, 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 ..
DOUBLE PRECISION Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
$ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
LOGICAL IEEE
INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB,
$ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT,
$ TTYPE
DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX,
$ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL,
$ TOL2, TRACE, ZMAX, TEMPE, TEMPQ
* ..
* .. External Subroutines ..
EXTERNAL DLASQ3, DLASRT, XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH, ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input arguments.
* (in case DLASQ2 is not called by DLASQ1)
*
INFO = 0
EPS = DLAMCH( 'Precision' )
SAFMIN = DLAMCH( 'Safe minimum' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DLASQ2', 1 )
RETURN
ELSE IF( N.EQ.0 ) THEN
RETURN
ELSE IF( N.EQ.1 ) THEN
*
* 1-by-1 case.
*
IF( Z( 1 ).LT.ZERO ) THEN
INFO = -201
CALL XERBLA( 'DLASQ2', 2 )
END IF
RETURN
ELSE IF( N.EQ.2 ) THEN
*
* 2-by-2 case.
*
IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
INFO = -2
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
D = Z( 3 )
Z( 3 ) = Z( 1 )
Z( 1 ) = D
END IF
Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
S = Z( 3 )*( Z( 2 ) / T )
IF( S.LE.T ) THEN
S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( 1 ) + ( S+Z( 2 ) )
Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
Z( 1 ) = T
END IF
Z( 2 ) = Z( 3 )
Z( 6 ) = Z( 2 ) + Z( 1 )
RETURN
END IF
*
* Check for negative data and compute sums of q's and e's.
*
Z( 2*N ) = ZERO
EMIN = Z( 2 )
QMAX = ZERO
ZMAX = ZERO
D = ZERO
E = ZERO
*
DO 10 K = 1, 2*( N-1 ), 2
IF( Z( K ).LT.ZERO ) THEN
INFO = -( 200+K )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
ELSE IF( Z( K+1 ).LT.ZERO ) THEN
INFO = -( 200+K+1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( K )
E = E + Z( K+1 )
QMAX = MAX( QMAX, Z( K ) )
EMIN = MIN( EMIN, Z( K+1 ) )
ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
10 CONTINUE
IF( Z( 2*N-1 ).LT.ZERO ) THEN
INFO = -( 200+2*N-1 )
CALL XERBLA( 'DLASQ2', 2 )
RETURN
END IF
D = D + Z( 2*N-1 )
QMAX = MAX( QMAX, Z( 2*N-1 ) )
ZMAX = MAX( QMAX, ZMAX )
*
* Check for diagonality.
*
IF( E.EQ.ZERO ) THEN
DO 20 K = 2, N
Z( K ) = Z( 2*K-1 )
20 CONTINUE
CALL DLASRT( 'D', N, Z, IINFO )
Z( 2*N-1 ) = D
RETURN
END IF
*
TRACE = D + E
*
* Check for zero data.
*
IF( TRACE.EQ.ZERO ) THEN
Z( 2*N-1 ) = ZERO
RETURN
END IF
*
* Check whether the machine is IEEE conformable.
*
IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
$ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
*
* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
DO 30 K = 2*N, 2, -2
Z( 2*K ) = ZERO
Z( 2*K-1 ) = Z( K )
Z( 2*K-2 ) = ZERO
Z( 2*K-3 ) = Z( K-1 )
30 CONTINUE
*
I0 = 1
N0 = N
*
* Reverse the qd-array, if warranted.
*
IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
40 CONTINUE
END IF
*
* Initial split checking via dqd and Li's test.
*
PP = 0
*
DO 80 K = 1, 2
*
D = Z( 4*N0+PP-3 )
DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
D = Z( I4-3 )
ELSE
D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
END IF
50 CONTINUE
*
* dqd maps Z to ZZ plus Li's test.
*
EMIN = Z( 4*I0+PP+1 )
D = Z( 4*I0+PP-3 )
DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
Z( I4-2*PP-2 ) = D + Z( I4-1 )
IF( Z( I4-1 ).LE.TOL2*D ) THEN
Z( I4-1 ) = -ZERO
Z( I4-2*PP-2 ) = D
Z( I4-2*PP ) = ZERO
D = Z( I4+1 )
ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
$ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
Z( I4-2*PP ) = Z( I4-1 )*TEMP
D = D*TEMP
ELSE
Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
END IF
EMIN = MIN( EMIN, Z( I4-2*PP ) )
60 CONTINUE
Z( 4*N0-PP-2 ) = D
*
* Now find qmax.
*
QMAX = Z( 4*I0-PP-2 )
DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
QMAX = MAX( QMAX, Z( I4 ) )
70 CONTINUE
*
* Prepare for the next iteration on K.
*
PP = 1 - PP
80 CONTINUE
*
* Initialise variables to pass to DLASQ3.
*
TTYPE = 0
DMIN1 = ZERO
DMIN2 = ZERO
DN = ZERO
DN1 = ZERO
DN2 = ZERO
G = ZERO
TAU = ZERO
*
ITER = 2
NFAIL = 0
NDIV = 2*( N0-I0 )
*
DO 160 IWHILA = 1, N + 1
IF( N0.LT.1 )
$ GO TO 170
*
* While array unfinished do
*
* E(N0) holds the value of SIGMA when submatrix in I0:N0
* splits from the rest of the array, but is negated.
*
DESIG = ZERO
IF( N0.EQ.N ) THEN
SIGMA = ZERO
ELSE
SIGMA = -Z( 4*N0-1 )
END IF
IF( SIGMA.LT.ZERO ) THEN
INFO = 1
RETURN
END IF
*
* Find last unreduced submatrix's top index I0, find QMAX and
* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
*
EMAX = ZERO
IF( N0.GT.I0 ) THEN
EMIN = ABS( Z( 4*N0-5 ) )
ELSE
EMIN = ZERO
END IF
QMIN = Z( 4*N0-3 )
QMAX = QMIN
DO 90 I4 = 4*N0, 8, -4
IF( Z( I4-5 ).LE.ZERO )
$ GO TO 100
IF( QMIN.GE.FOUR*EMAX ) THEN
QMIN = MIN( QMIN, Z( I4-3 ) )
EMAX = MAX( EMAX, Z( I4-5 ) )
END IF
QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
EMIN = MIN( EMIN, Z( I4-5 ) )
90 CONTINUE
I4 = 4
*
100 CONTINUE
I0 = I4 / 4
PP = 0
*
IF( N0-I0.GT.1 ) THEN
DEE = Z( 4*I0-3 )
DEEMIN = DEE
KMIN = I0
DO 110 I4 = 4*I0+1, 4*N0-3, 4
DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) )
IF( DEE.LE.DEEMIN ) THEN
DEEMIN = DEE
KMIN = ( I4+3 )/4
END IF
110 CONTINUE
IF( (KMIN-I0)*2.LT.N0-KMIN .AND.
$ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN
IPN4 = 4*( I0+N0 )
PP = 2
DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( I4-3 )
Z( I4-3 ) = Z( IPN4-I4-3 )
Z( IPN4-I4-3 ) = TEMP
TEMP = Z( I4-2 )
Z( I4-2 ) = Z( IPN4-I4-2 )
Z( IPN4-I4-2 ) = TEMP
TEMP = Z( I4-1 )
Z( I4-1 ) = Z( IPN4-I4-5 )
Z( IPN4-I4-5 ) = TEMP
TEMP = Z( I4 )
Z( I4 ) = Z( IPN4-I4-4 )
Z( IPN4-I4-4 ) = TEMP
120 CONTINUE
END IF
END IF
*
* Put -(initial shift) into DMIN.
*
DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
*
* Now I0:N0 is unreduced.
* PP = 0 for ping, PP = 1 for pong.
* PP = 2 indicates that flipping was applied to the Z array and
* and that the tests for deflation upon entry in DLASQ3
* should not be performed.
*
NBIG = 100*( N0-I0+1 )
DO 140 IWHILB = 1, NBIG
IF( I0.GT.N0 )
$ GO TO 150
*
* While submatrix unfinished take a good dqds step.
*
CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, G, TAU )
*
PP = 1 - PP
*
* When EMIN is very small check for splits.
*
IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
$ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
SPLT = I0 - 1
QMAX = Z( 4*I0-3 )
EMIN = Z( 4*I0-1 )
OLDEMN = Z( 4*I0 )
DO 130 I4 = 4*I0, 4*( N0-3 ), 4
IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
$ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
Z( I4-1 ) = -SIGMA
SPLT = I4 / 4
QMAX = ZERO
EMIN = Z( I4+3 )
OLDEMN = Z( I4+4 )
ELSE
QMAX = MAX( QMAX, Z( I4+1 ) )
EMIN = MIN( EMIN, Z( I4-1 ) )
OLDEMN = MIN( OLDEMN, Z( I4 ) )
END IF
130 CONTINUE
Z( 4*N0-1 ) = EMIN
Z( 4*N0 ) = OLDEMN
I0 = SPLT + 1
END IF
END IF
*
140 CONTINUE
*
INFO = 2
*
* Maximum number of iterations exceeded, restore the shift
* SIGMA and place the new d's and e's in a qd array.
* This might need to be done for several blocks
*
I1 = I0
N1 = N0
145 CONTINUE
TEMPQ = Z( 4*I0-3 )
Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA
DO K = I0+1, N0
TEMPE = Z( 4*K-5 )
Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 ))
TEMPQ = Z( 4*K-3 )
Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 )
END DO
*
* Prepare to do this on the previous block if there is one
*
IF( I1.GT.1 ) THEN
N1 = I1-1
DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) )
I1 = I1 - 1
END DO
SIGMA = -Z(4*N1-1)
GO TO 145
END IF
DO K = 1, N
Z( 2*K-1 ) = Z( 4*K-3 )
*
* Only the block 1..N0 is unfinished. The rest of the e's
* must be essentially zero, although sometimes other data
* has been stored in them.
*
IF( K.LT.N0 ) THEN
Z( 2*K ) = Z( 4*K-1 )
ELSE
Z( 2*K ) = 0
END IF
END DO
RETURN
*
* end IWHILB
*
150 CONTINUE
*
160 CONTINUE
*
INFO = 3
RETURN
*
* end IWHILA
*
170 CONTINUE
*
* Move q's to the front.
*
DO 180 K = 2, N
Z( K ) = Z( 4*K-3 )
180 CONTINUE
*
* Sort and compute sum of eigenvalues.
*
CALL DLASRT( 'D', N, Z, IINFO )
*
E = ZERO
DO 190 K = N, 1, -1
E = E + Z( K )
190 CONTINUE
*
* Store trace, sum(eigenvalues) and information on performance.
*
Z( 2*N+1 ) = TRACE
Z( 2*N+2 ) = E
Z( 2*N+3 ) = DBLE( ITER )
Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
RETURN
*
* End of DLASQ2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlarfg.f 0000644 0000000 0000000 00000000132 14061636515 015263 x ustar 00 30 mtime=1623670093.375103921
30 atime=1623670093.375103921
30 ctime=1623670093.375103921
elk-7.2.42/src/LAPACK/dlarfg.f 0000644 0025044 0025044 00000011620 14061636515 017320 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARFG generates an elementary reflector (Householder matrix).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFG generates a real elementary reflector H of order n, such
*> that
*>
*> H * ( alpha ) = ( beta ), H**T * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, and x is an (n-1)-element real
*> vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
*> ( v )
*>
*> where tau is a real scalar and v is a real (n-1)-element
*> vector.
*>
*> If the elements of x are all zero, then tau = 0 and H is taken to be
*> the unit matrix.
*>
*> Otherwise 1 <= tau <= 2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION 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 DOUBLE PRECISION
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup doubleOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.8.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2017
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL DLAMCH, DLAPY2, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
10 CONTINUE
KNT = KNT + 1
CALL DSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHA = ALPHA*RSAFMN
IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DNRM2( N-1, X, INCX )
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
END IF
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), 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 DLARFG
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorg2l.f 0000644 0000000 0000000 00000000127 14061636515 015221 x ustar 00 29 mtime=1623670093.37710392
29 atime=1623670093.37710392
29 ctime=1623670093.37710392
elk-7.2.42/src/LAPACK/dorg2l.f 0000644 0025044 0025044 00000012206 14061636515 017253 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORG2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORG2L generates an m by n real matrix Q with orthonormal columns,
*> which is defined as the last n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by DGEQLF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the (n-k+i)-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGEQLF in the last k columns of its array
*> argument A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQLF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has 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 doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, 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 ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORG2L
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlarft.f 0000644 0000000 0000000 00000000132 14061636515 015300 x ustar 00 30 mtime=1623670093.379103918
30 atime=1623670093.379103918
30 ctime=1623670093.379103918
elk-7.2.42/src/LAPACK/dlarft.f 0000644 0025044 0025044 00000024026 14061636515 017341 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARFT 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 DLARFT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* .. Scalar Arguments ..
* CHARACTER DIRECT, STOREV
* INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFT forms the triangular factor T of a real 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**T
*>
*> 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**T * 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is DOUBLE PRECISION array, dimension (LDT,K)
*> The k by k triangular factor T of the block reflector.
*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*> lower triangular. The rest of the array is not used.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= K.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- 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, STOREV
INTEGER K, LDT, LDV, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, PREVLASTV, LASTV
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DTRMV
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( LSAME( DIRECT, 'F' ) ) THEN
PREVLASTV = N
DO I = 1, K
PREVLASTV = MAX( I, PREVLASTV )
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = 1, I
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( I , J )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
*
CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ),
$ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE,
$ T( 1, I ), 1 )
ELSE
* Skip any trailing zeros.
DO LASTV = N, I+1, -1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = 1, I-1
T( J, I ) = -TAU( I ) * V( J , I )
END DO
J = MIN( LASTV, PREVLASTV )
*
* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
*
CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ),
$ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE,
$ T( 1, I ), 1 )
END IF
*
* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
$ LDT, T( 1, I ), 1 )
T( I, I ) = TAU( I )
IF( I.GT.1 ) THEN
PREVLASTV = MAX( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
END DO
ELSE
PREVLASTV = 1
DO I = K, 1, -1
IF( TAU( I ).EQ.ZERO ) THEN
*
* H(i) = I
*
DO J = I, K
T( J, I ) = ZERO
END DO
ELSE
*
* general case
*
IF( I.LT.K ) THEN
IF( LSAME( STOREV, 'C' ) ) THEN
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( LASTV, I ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( N-K+I , J )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
*
CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ),
$ V( J, I+1 ), LDV, V( J, I ), 1, ONE,
$ T( I+1, I ), 1 )
ELSE
* Skip any leading zeros.
DO LASTV = 1, I-1
IF( V( I, LASTV ).NE.ZERO ) EXIT
END DO
DO J = I+1, K
T( J, I ) = -TAU( I ) * V( J, N-K+I )
END DO
J = MAX( LASTV, PREVLASTV )
*
* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
*
CALL DGEMV( 'No transpose', K-I, N-K+I-J,
$ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
$ ONE, T( I+1, I ), 1 )
END IF
*
* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
$ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
IF( I.GT.1 ) THEN
PREVLASTV = MIN( PREVLASTV, LASTV )
ELSE
PREVLASTV = LASTV
END IF
END IF
T( I, I ) = TAU( I )
END IF
END DO
END IF
RETURN
*
* End of DLARFT
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlarfb.f 0000644 0000000 0000000 00000000132 14061636515 015256 x ustar 00 30 mtime=1623670093.381103916
30 atime=1623670093.381103916
30 ctime=1623670093.381103916
elk-7.2.42/src/LAPACK/dlarfb.f 0000644 0025044 0025044 00000051425 14061636515 017322 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFB( 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 ..
* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
* $ WORK( LDWORK, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFB applies a real block reflector H or its transpose H**T to a
*> real 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**T from the Left
*> = 'R': apply H or H**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply H (No transpose)
*> = 'T': apply H**T (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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
*> \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 DOUBLE PRECISION array, dimension (LDWORK,K)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*> LDWORK is INTEGER
*> The leading dimension of the array WORK.
*> If SIDE = 'L', LDWORK >= max(1,N);
*> if SIDE = 'R', LDWORK >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2013
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The shape of the matrix V and the storage of the vectors which define
*> the H(i) is best illustrated by the following example with n = 5 and
*> k = 3. The elements equal to 1 are not stored; the corresponding
*> array elements are modified but restored on exit. The rest of the
*> array is not used.
*>
*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*>
*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*> ( v1 1 ) ( 1 v2 v2 v2 )
*> ( v1 v2 1 ) ( 1 v3 v3 )
*> ( v1 v2 v3 )
*> ( v1 v2 v3 )
*>
*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*>
*> V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*> ( v1 v2 v3 ) ( v2 v2 v2 1 )
*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*> ( 1 v3 )
*> ( 1 )
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- 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 2013
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
INTEGER K, LDC, LDT, LDV, LDWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
$ WORK( LDWORK, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER TRANST
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DTRMM
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( M.LE.0 .OR. N.LE.0 )
$ RETURN
*
IF( LSAME( TRANS, 'N' ) ) THEN
TRANST = 'T'
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**T * C where C = ( C1 )
* ( C2 )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C1**T
*
DO 10 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
10 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**T * V2
*
CALL DGEMM( '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**T or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
$ C( K+1, 1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 30 J = 1, K
DO 20 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
20 CONTINUE
30 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C1
*
DO 40 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
40 CONTINUE
*
* W := W * V1
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
$ K, ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2
*
CALL DGEMM( '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**T
*
CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
IF( N.GT.K ) THEN
*
* C2 := C2 - W * V2**T
*
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
$ C( 1, K+1 ), LDC )
END IF
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Lower', '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**T * C where C = ( C1 )
* ( C2 )
*
* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
*
* W := C2**T
*
DO 70 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
70 CONTINUE
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1
*
CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V * W**T
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1 * W**T
*
CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
$ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 90 J = 1, K
DO 80 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
80 CONTINUE
90 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
*
* W := C2
*
DO 100 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
100 CONTINUE
*
* W := W * V2
*
CALL DTRMM( '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 DGEMM( 'No transpose', 'No transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - W * V**T
*
IF( N.GT.K ) THEN
*
* C1 := C1 - W * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Upper', '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**T * C where C = ( C1 )
* ( C2 )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C1**T
*
DO 130 J = 1, K
CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
130 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C2**T * V2**T
*
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
$ WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( M.GT.K ) THEN
*
* C2 := C2 - V2**T * W**T
*
CALL DGEMM( 'Transpose', '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 DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
$ K, ONE, V, LDV, WORK, LDWORK )
*
* C1 := C1 - W**T
*
DO 150 J = 1, K
DO 140 I = 1, N
C( J, I ) = C( J, I ) - WORK( I, J )
140 CONTINUE
150 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H**T where C = ( C1 C2 )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C1
*
DO 160 J = 1, K
CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
160 CONTINUE
*
* W := W * V1**T
*
CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
$ ONE, V, LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C2 * V2**T
*
CALL DGEMM( 'No transpose', '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**T
*
CALL DTRMM( '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 DGEMM( '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 DTRMM( '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**T * C where C = ( C1 )
* ( C2 )
*
* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
*
* W := C2**T
*
DO 190 J = 1, K
CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
190 CONTINUE
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
$ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
IF( M.GT.K ) THEN
*
* W := W + C1**T * V1**T
*
CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
$ C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T**T or W * T
*
CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
$ ONE, T, LDT, WORK, LDWORK )
*
* C := C - V**T * W**T
*
IF( M.GT.K ) THEN
*
* C1 := C1 - V1**T * W**T
*
CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
$ V, LDV, WORK, LDWORK, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
$ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
* C2 := C2 - W**T
*
DO 210 J = 1, K
DO 200 I = 1, N
C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
200 CONTINUE
210 CONTINUE
*
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form C * H or C * H' where C = ( C1 C2 )
*
* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
*
* W := C2
*
DO 220 J = 1, K
CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
220 CONTINUE
*
* W := W * V2**T
*
CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
$ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
IF( N.GT.K ) THEN
*
* W := W + C1 * V1**T
*
CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
$ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
END IF
*
* W := W * T or W * T**T
*
CALL DTRMM( '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 DGEMM( 'No transpose', 'No transpose', M, N-K, K,
$ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
END IF
*
* W := W * V2
*
CALL DTRMM( '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 DLARFB
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorg2r.f 0000644 0000000 0000000 00000000132 14061636515 015223 x ustar 00 30 mtime=1623670093.383103914
30 atime=1623670093.383103914
30 ctime=1623670093.383103914
elk-7.2.42/src/LAPACK/dorg2r.f 0000644 0025044 0025044 00000012220 14061636515 017255 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORG2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORG2R generates an m by n real matrix Q with orthonormal columns,
*> which is defined as the first n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGEQRF in the first k columns of its array
*> argument A.
*> On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has 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 doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, 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 ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORG2R
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dormql.f 0000644 0000000 0000000 00000000132 14061636515 015322 x ustar 00 30 mtime=1623670093.385103912
30 atime=1623670093.385103912
30 ctime=1623670093.385103912
elk-7.2.42/src/LAPACK/dormql.f 0000644 0025044 0025044 00000022275 14061636515 017367 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORMQL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMQL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMQL( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORMQL overwrites the general real M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by DGEQLF. 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**T from the Left;
*> = 'R': apply Q or Q**T from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'T': Transpose, apply Q**T.
*> \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 DOUBLE PRECISION 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
*> DGEQLF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT,
$ MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORM2L, 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, '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 .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, 'DORMQL', SIDE // TRANS, M, N,
$ K, -1 ) )
LWKOPT = NW*NB + TSIZE
END IF
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQL', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 ) THEN
RETURN
END IF
*
NBMIN = 2
LDWORK = NW
IF( NB.GT.1 .AND. NB.LT.K ) THEN
IF( LWORK.LT.NW*NB+TSIZE ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL DORM2L( 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 DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
$ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**T is applied to C(1:m-k+i+ib-1,1:n)
*
MI = M - K + I + IB - 1
ELSE
*
* H or H**T is applied to C(1:m,1:n-k+i+ib-1)
*
NI = N - K + I + IB - 1
END IF
*
* Apply H or H**T
*
CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
$ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC,
$ WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMQL
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dormqr.f 0000644 0000000 0000000 00000000127 14061636515 015334 x ustar 00 29 mtime=1623670093.38710391
29 atime=1623670093.38710391
29 ctime=1623670093.38710391
elk-7.2.42/src/LAPACK/dormqr.f 0000644 0025044 0025044 00000022241 14061636515 017366 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORMQR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMQR( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORMQR overwrites the general real M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'T': Q**T * C C * Q**T
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF. 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**T from the Left;
*> = 'R': apply Q or Q**T from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': No transpose, apply Q;
*> = 'T': Transpose, apply Q**T.
*> \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 DOUBLE PRECISION 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
*> DGEQRF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T 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 DOUBLE PRECISION 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.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NBMAX, LDT, TSIZE
PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
$ TSIZE = LDT*NBMAX )
* ..
* .. Local Scalars ..
LOGICAL LEFT, LQUERY, NOTRAN
INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
$ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLARFB, DLARFT, DORM2R, 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 = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -12
END IF
*
IF( INFO.EQ.0 ) THEN
*
* Compute the workspace requirements
*
NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
LWKOPT = MAX( 1, NW )*NB + TSIZE
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMQR', -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.NW*NB+TSIZE ) THEN
NB = (LWORK-TSIZE) / LDWORK
NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K,
$ -1 ) )
END IF
END IF
*
IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
* Use unblocked code
*
CALL DORM2R( 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 DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
$ LDA, TAU( I ), WORK( IWT ), LDT )
IF( LEFT ) THEN
*
* H or H**T is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H or H**T is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H or H**T
*
CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
$ IB, A( I, I ), LDA, WORK( IWT ), LDT,
$ C( IC, JC ), LDC, WORK, LDWORK )
10 CONTINUE
END IF
WORK( 1 ) = LWKOPT
RETURN
*
* End of DORMQR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed0.f 0000644 0000000 0000000 00000000132 14061636515 015155 x ustar 00 30 mtime=1623670093.389103908
30 atime=1623670093.389103908
30 ctime=1623670093.389103908
elk-7.2.42/src/LAPACK/dlaed0.f 0000644 0025044 0025044 00000033106 14061636515 017215 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED0 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 DLAED0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED0( 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( * )
* DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
* $ WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED0 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 DOUBLE PRECISION array, dimension (N)
*> On entry, the main diagonal of the tridiagonal matrix.
*> On exit, its eigenvalues.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAED0( 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( * )
DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
$ WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
* ..
* .. 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
DOUBLE PRECISION TEMP
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
$ XERBLA
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, INT, LOG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
INFO = -1
ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
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( 'DLAED0', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 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( DBLE( N ) ) / LOG( TWO )
LGN = INT( TEMP )
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IF( 2**LGN.LT.N )
$ LGN = LGN + 1
IPRMPT = INDXQ + N + 1
IPERM = IPRMPT + N*LGN
IQPTR = IPERM + N*LGN
IGIVPT = IQPTR + N + 2
IGIVCL = IGIVPT + N*LGN
*
IGIVNM = 1
IQ = IGIVNM + 2*N*LGN
IWREM = IQ + N**2 + 1
*
* Initialize pointers
*
DO 50 I = 0, SUBPBS
IWORK( IPRMPT+I ) = 1
IWORK( IGIVPT+I ) = 1
50 CONTINUE
IWORK( IQPTR ) = 1
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 DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
$ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
IF( INFO.NE.0 )
$ GO TO 130
ELSE
CALL DSTEQR( '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 DGEMM( '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.
* DLAED1 is used only for the full eigensystem of a tridiagonal
* matrix.
* DLAED7 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 DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
$ LDQ, IWORK( INDXQ+SUBMAT ),
$ E( SUBMAT+MSD2-1 ), MSD2, WORK,
$ IWORK( SUBPBS+1 ), INFO )
ELSE
CALL DLAED7( 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 DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
100 CONTINUE
CALL DCOPY( 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 DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
110 CONTINUE
CALL DCOPY( N, WORK, 1, D, 1 )
CALL DLACPY( '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 DCOPY( N, WORK, 1, D, 1 )
END IF
GO TO 140
*
130 CONTINUE
INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
*
140 CONTINUE
RETURN
*
* End of DLAED0
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlacgv.f 0000644 0000000 0000000 00000000132 14061636515 015312 x ustar 00 30 mtime=1623670093.391103906
30 atime=1623670093.391103906
30 ctime=1623670093.391103906
elk-7.2.42/src/LAPACK/zlacgv.f 0000644 0025044 0025044 00000005444 14061636515 017356 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLACGV conjugates a complex vector.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLACGV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLACGV( N, X, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* ..
* .. Array Arguments ..
* COMPLEX*16 X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLACGV conjugates a complex vector of length N.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The length of the vector X. N >= 0.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX*16 array, dimension
*> (1+(N-1)*abs(INCX))
*> On entry, the vector of length N to be conjugated.
*> On exit, X is overwritten with conjg(X).
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The spacing between successive elements of X.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZLACGV( N, X, INCX )
*
* -- 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 ..
INTEGER INCX, N
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IOFF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( INCX.EQ.1 ) THEN
DO 10 I = 1, N
X( I ) = DCONJG( X( I ) )
10 CONTINUE
ELSE
IOFF = 1
IF( INCX.LT.0 )
$ IOFF = 1 - ( N-1 )*INCX
DO 20 I = 1, N
X( IOFF ) = DCONJG( X( IOFF ) )
IOFF = IOFF + INCX
20 CONTINUE
END IF
RETURN
*
* End of ZLACGV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaed7.f 0000644 0000000 0000000 00000000132 14061636515 015212 x ustar 00 30 mtime=1623670093.393103905
30 atime=1623670093.393103905
30 ctime=1623670093.393103905
elk-7.2.42/src/LAPACK/zlaed7.f 0000644 0025044 0025044 00000030363 14061636515 017254 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAED7 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 ZLAED7 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
* LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
* GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
* $ TLVLS
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
* COMPLEX*16 Q( LDQ, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAED7 computes the updated eigensystem of a diagonal
*> matrix after modification by a rank-one symmetric matrix. This
*> routine is used only for the eigenproblem which requires all
*> eigenvalues and optionally eigenvectors of a dense or banded
*> Hermitian matrix that has been reduced to tridiagonal form.
*>
*> T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
*>
*> where Z = Q**Hu, u is a vector of length N with ones in the
*> CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
*>
*> The eigenvectors of the original matrix are stored in Q, and the
*> eigenvalues are in D. The algorithm consists of three stages:
*>
*> The first stage consists of deflating the size of the problem
*> when there are multiple eigenvalues or if there is a zero in
*> the Z vector. For each such occurrence the dimension of the
*> secular equation problem is reduced by one. This stage is
*> performed by the routine DLAED2.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine DLAED4 (as called by SLAED3).
*> This routine also calculates the eigenvectors of the current
*> problem.
*>
*> The final stage consists of computing the updated eigenvectors
*> directly using the updated eigenvalues. The eigenvectors for
*> the current problem are multiplied with the eigenvectors from
*> the overall problem.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> Contains the location of the last eigenvalue in the leading
*> sub-matrix. min(1,N) <= CUTPNT <= N.
*> \endverbatim
*>
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the full matrix to tridiagonal form. QSIZ >= N.
*> \endverbatim
*>
*> \param[in] TLVLS
*> \verbatim
*> TLVLS is INTEGER
*> The total number of merging levels in the overall divide and
*> conquer tree.
*> \endverbatim
*>
*> \param[in] CURLVL
*> \verbatim
*> CURLVL is INTEGER
*> The current level in the overall merge routine,
*> 0 <= curlvl <= tlvls.
*> \endverbatim
*>
*> \param[in] CURPBM
*> \verbatim
*> CURPBM is INTEGER
*> The current problem in the current level in the overall
*> merge routine (counting from upper left to lower right).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, the eigenvalues of the rank-1-perturbed matrix.
*> On exit, the eigenvalues of the repaired matrix.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, the eigenvectors of the rank-1-perturbed matrix.
*> On exit, the eigenvectors of the repaired tridiagonal matrix.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> Contains the subdiagonal element used to create the rank-1
*> modification.
*> \endverbatim
*>
*> \param[out] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> This contains the permutation which will reintegrate the
*> subproblem just solved back into sorted order,
*> ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (4*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is DOUBLE PRECISION array,
*> dimension (3*N+2*QSIZ*N)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (QSIZ*N)
*> \endverbatim
*>
*> \param[in,out] QSTORE
*> \verbatim
*> QSTORE is DOUBLE PRECISION array, dimension (N**2+1)
*> Stores eigenvectors of submatrices encountered during
*> divide and conquer, packed together. QPTR points to
*> beginning of the submatrices.
*> \endverbatim
*>
*> \param[in,out] QPTR
*> \verbatim
*> QPTR is INTEGER array, dimension (N+2)
*> List of indices pointing to beginning of submatrices stored
*> in QSTORE. The submatrices are numbered starting at the
*> bottom left of the divide and conquer tree, from left to
*> right and bottom to top.
*> \endverbatim
*>
*> \param[in] PRMPTR
*> \verbatim
*> PRMPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in PERM a
*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
*> indicates the size of the permutation and also the size of
*> the full, non-deflated problem.
*> \endverbatim
*>
*> \param[in] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N lg N)
*> Contains the permutations (from deflation and sorting) to be
*> applied to each eigenblock.
*> \endverbatim
*>
*> \param[in] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in GIVCOL a
*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
*> indicates the number of Givens rotations.
*> \endverbatim
*>
*> \param[in] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension (2, N lg N)
*> Each pair of numbers indicates a pair of columns to take place
*> in a Givens rotation.
*> \endverbatim
*>
*> \param[in] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> > 0: if INFO = 1, an eigenvalue did not converge
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
$ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine (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, INFO, LDQ, N, QSIZ,
$ TLVLS
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
COMPLEX*16 Q( LDQ, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX,
$ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
* INFO = -1
* ELSE IF( N.LT.0 ) THEN
IF( N.LT.0 ) THEN
INFO = -1
ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED7', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
* The following values are for bookkeeping purposes only. They are
* integer pointers which indicate the portion of the workspace
* used by a particular array in DLAED2 and SLAED3.
*
IZ = 1
IDLMDA = IZ + N
IW = IDLMDA + N
IQ = IW + N
*
INDX = 1
INDXC = INDX + N
COLTYP = INDXC + N
INDXP = COLTYP + N
*
* Form the z-vector which consists of the last row of Q_1 and the
* first row of Q_2.
*
PTR = 1 + 2**TLVLS
DO 10 I = 1, CURLVL - 1
PTR = PTR + 2**( TLVLS-I )
10 CONTINUE
CURR = PTR + CURPBM
CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
$ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
$ RWORK( IZ+N ), INFO )
*
* When solving the final problem, we no longer need the stored data,
* so we will overwrite the data from this level onto the previously
* used storage space.
*
IF( CURLVL.EQ.TLVLS ) THEN
QPTR( CURR ) = 1
PRMPTR( CURR ) = 1
GIVPTR( CURR ) = 1
END IF
*
* Sort and Deflate eigenvalues.
*
CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
$ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
$ IWORK( INDXP ), IWORK( INDX ), INDXQ,
$ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
$ GIVCOL( 1, GIVPTR( CURR ) ),
$ GIVNUM( 1, GIVPTR( CURR ) ), INFO )
PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
*
* Solve Secular Equation.
*
IF( K.NE.0 ) THEN
CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
$ RWORK( IDLMDA ), RWORK( IW ),
$ QSTORE( QPTR( CURR ) ), K, INFO )
CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q,
$ LDQ, RWORK( IQ ) )
QPTR( CURR+1 ) = QPTR( CURR ) + K**2
IF( INFO.NE.0 ) THEN
RETURN
END IF
*
* Prepare the INDXQ sorting premutation.
*
N1 = K
N2 = N - K
CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
RETURN
*
* End of ZLAED7
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zladiv.f 0000644 0000000 0000000 00000000132 14061636515 015315 x ustar 00 30 mtime=1623670093.395103903
30 atime=1623670093.395103903
30 ctime=1623670093.395103903
elk-7.2.42/src/LAPACK/zladiv.f 0000644 0025044 0025044 00000004571 14061636515 017361 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* .. Scalar Arguments ..
* COMPLEX*16 X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is COMPLEX*16
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX*16
*> The complex scalars X and Y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
* -- 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 ..
COMPLEX*16 X, Y
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
$ ZI )
ZLADIV = DCMPLX( ZR, ZI )
*
RETURN
*
* End of ZLADIV
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr3.f 0000644 0000000 0000000 00000000132 14061636515 015240 x ustar 00 30 mtime=1623670093.397103901
30 atime=1623670093.396103902
30 ctime=1623670093.397103901
elk-7.2.42/src/LAPACK/zlaqr3.f 0000644 0025044 0025044 00000043115 14061636515 017301 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
* NV, WV, LDWV, WORK, LWORK )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Aggressive early deflation:
*>
*> ZLAQR3 accepts as input an upper Hessenberg matrix
*> H and performs an unitary similarity transformation
*> designed to detect and deflate fully converged eigenvalues from
*> a trailing principal submatrix. On output H has been over-
*> written by a new Hessenberg matrix that is a perturbation of
*> an unitary similarity transformation of H. It is to be
*> hoped that the final version of H has many zero subdiagonal
*> entries.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> If .TRUE., then the Hessenberg matrix H is fully updated
*> so that the triangular Schur factor may be
*> computed (in cooperation with the calling subroutine).
*> If .FALSE., then only enough of H is updated to preserve
*> the eigenvalues.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> If .TRUE., then the unitary matrix Z is updated so
*> so that the unitary Schur factor may be computed
*> (in cooperation with the calling subroutine).
*> If .FALSE., then Z is not referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H and (if WANTZ is .TRUE.) the
*> order of the unitary matrix Z.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
*> KBOT and KTOP together determine an isolated block
*> along the diagonal of the Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> It is assumed without a check that either
*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
*> determine an isolated block along the diagonal of the
*> Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] NW
*> \verbatim
*> NW is INTEGER
*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> Leading dimension of H just as declared in the calling
*> subroutine. N <= LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
*> If WANTZ is .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of Z just as declared in the
*> calling subroutine. 1 <= LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is INTEGER
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is INTEGER
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension (KBOT)
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of V just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH >= NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of T just as declared in the
*> calling subroutine. NW <= LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV >= NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> The leading dimension of W just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR3
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.7.1) --
* -- 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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
$ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 BETA, CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
$ LWKOPT, NMIN
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
INTEGER ILAENV
EXTERNAL DLAMCH, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
$ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to ZGEHRD ====
*
CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZUNMHR ====
*
CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZLAQR4 ====
*
CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
$ LDV, WORK, -1, INFQR )
LWK3 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
WORK( 1 ) = ONE
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SH( KWTOP ) = H( KWTOP, KWTOP )
NS = 1
ND = 0
IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
$ KWTOP ) ) ) ) THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
IF( JW.GT.NMIN ) THEN
CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, WORK, LWORK, INFQR )
ELSE
CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, INFQR )
END IF
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
DO 10 KNT = INFQR + 1, JW
*
* ==== Small spike tip deflation test ====
*
FOO = CABS1( T( NS, NS ) )
IF( FOO.EQ.RZERO )
$ FOO = CABS1( S )
IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
$ THEN
*
* ==== One more converged eigenvalue ====
*
NS = NS - 1
ELSE
*
* ==== One undeflatable eigenvalue. Move it up out of the
* . way. (ZTREXC can not fail in this case.) ====
*
IFST = NS
CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
ILST = ILST + 1
END IF
10 CONTINUE
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting the diagonal of T improves accuracy for
* . graded matrices. ====
*
DO 30 I = INFQR + 1, NS
IFST = I
DO 20 J = I + 1, NS
IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
$ IFST = J
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
$ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
DO 40 I = INFQR + 1, JW
SH( KWTOP+I-1 ) = T( I, I )
40 CONTINUE
*
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL ZCOPY( NS, V, LDV, WORK, 1 )
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
BETA = WORK( 1 )
CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
$ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 60 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 70 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
70 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
80 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR3 ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr4.f 0000644 0000000 0000000 00000000132 14061636515 015241 x ustar 00 30 mtime=1623670093.399103899
30 atime=1623670093.399103899
30 ctime=1623670093.399103899
elk-7.2.42/src/LAPACK/zlaqr4.f 0000644 0025044 0025044 00000060765 14061636515 017314 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR4 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
* IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR4 implements one level of recursion for ZLAQR0.
*> It is a complete implementation of the small bulge multi-shift
*> QR algorithm. It may be called by ZLAQR0 and, for large enough
*> deflation window size, it may be called by ZLAQR3. This
*> subroutine is identical to ZLAQR0 except that it calls ZLAQR2
*> instead of ZLAQR3.
*>
*> ZLAQR4 computes the eigenvalues of a Hessenberg matrix H
*> and, optionally, the matrices T and Z from the Schur decomposition
*> H = Z T Z**H, where T is an upper triangular matrix (the
*> Schur form), and Z is the unitary matrix of Schur vectors.
*>
*> Optionally Z may be postmultiplied into an input unitary
*> matrix Q so that this routine can give the Schur factorization
*> of a matrix A which has been reduced to the Hessenberg form H
*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> = .TRUE. : the full Schur form T is required;
*> = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> = .TRUE. : the matrix of Schur vectors Z is required;
*> = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*> It is assumed that H is already upper triangular in rows
*> and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
*> previous call to ZGEBAL, and then passed to ZGEHRD when the
*> matrix output by ZGEBAL is reduced to Hessenberg form.
*> Otherwise, ILO and IHI should be set to 1 and N,
*> respectively. If N > 0, then 1 <= ILO <= IHI <= N.
*> If N = 0, then ILO = 1 and IHI = 0.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On entry, the upper Hessenberg matrix H.
*> On exit, if INFO = 0 and WANTT is .TRUE., then H
*> contains the upper triangular matrix T from the Schur
*> decomposition (the Schur form). If INFO = 0 and WANT is
*> .FALSE., then the contents of H are unspecified on exit.
*> (The output value of H when INFO > 0 is given under the
*> description of INFO below.)
*>
*> This subroutine may explicitly set H(i,j) = 0 for i > j and
*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is COMPLEX*16 array, dimension (N)
*> The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
*> in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
*> stored in the same order as on the diagonal of the Schur
*> form returned in H, with W(i) = H(i,i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE..
*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHI)
*> If WANTZ is .FALSE., then Z is not referenced.
*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
*> (The output value of Z when INFO > 0 is given under
*> the description of INFO below.)
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. if WANTZ is .TRUE.
*> then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension LWORK
*> On exit, if LWORK = -1, WORK(1) returns an estimate of
*> the optimal value for LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= max(1,N)
*> is sufficient, but LWORK typically as large as 6*N may
*> be required for optimal performance. A workspace query
*> to determine the optimal workspace size is recommended.
*>
*> If LWORK = -1, then ZLAQR4 does a workspace query.
*> In this case, ZLAQR4 checks the input parameters and
*> estimates the optimal workspace size for the given
*> values of N, ILO and IHI. The estimate is returned
*> in WORK(1). No error message related to LWORK is
*> issued by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = i, ZLAQR4 failed to compute all of
*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
*> and WI contain those eigenvalues which have been
*> successfully computed. (Failures are rare.)
*>
*> If INFO > 0 and WANT is .FALSE., then on exit,
*> the remaining unconverged eigenvalues are the eigen-
*> values of the upper Hessenberg matrix rows and
*> columns ILO through INFO of the final, output
*> value of H.
*>
*> If INFO > 0 and WANTT is .TRUE., then on exit
*>
*> (*) (initial value of H)*U = U*(final value of H)
*>
*> where U is a unitary matrix. The final
*> value of H is upper Hessenberg and triangular in
*> rows and columns INFO+1 through IHI.
*>
*> If INFO > 0 and WANTZ is .TRUE., then on exit
*>
*> (final value of Z(ILO:IHI,ILOZ:IHIZ)
*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
*>
*> where U is the unitary matrix in (*) (regard-
*> less of the value of WANTT.)
*>
*> If INFO > 0 and WANTZ is .FALSE., then Z is not
*> accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*> \n
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal
*> of Matrix Analysis, volume 23, pages 948--973, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.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 IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
*
* ==== Matrices of order NTINY or smaller must be processed by
* . ZLAHQR because of insufficient subdiagonal scratch space.
* . (This is a hard limit.) ====
INTEGER NTINY
PARAMETER ( NTINY = 11 )
*
* ==== Exceptional deflation windows: try to cure rare
* . slow convergence by varying the size of the
* . deflation window after KEXNW iterations. ====
INTEGER KEXNW
PARAMETER ( KEXNW = 5 )
*
* ==== Exceptional shifts: try to cure rare slow convergence
* . with ad-hoc exceptional shifts every KEXSH iterations.
* . ====
INTEGER KEXSH
PARAMETER ( KEXSH = 6 )
*
* ==== The constant WILK1 is used to form the exceptional
* . shifts. ====
DOUBLE PRECISION WILK1
PARAMETER ( WILK1 = 0.75d0 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
DOUBLE PRECISION S
INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
$ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
$ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
$ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
LOGICAL SORTED
CHARACTER JBCMPZ*2
* ..
* .. External Functions ..
INTEGER ILAENV
EXTERNAL ILAENV
* ..
* .. Local Arrays ..
COMPLEX*16 ZDUM( 1, 1 )
* ..
* .. External Subroutines ..
EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
$ SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
INFO = 0
*
* ==== Quick return for N = 0: nothing to do. ====
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = ONE
RETURN
END IF
*
IF( N.LE.NTINY ) THEN
*
* ==== Tiny matrices must use ZLAHQR. ====
*
LWKOPT = 1
IF( LWORK.NE.-1 )
$ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
ELSE
*
* ==== Use small bulge multi-shift QR with aggressive early
* . deflation on larger-than-tiny matrices. ====
*
* ==== Hope for the best. ====
*
INFO = 0
*
* ==== Set up job flags for ILAENV. ====
*
IF( WANTT ) THEN
JBCMPZ( 1: 1 ) = 'S'
ELSE
JBCMPZ( 1: 1 ) = 'E'
END IF
IF( WANTZ ) THEN
JBCMPZ( 2: 2 ) = 'V'
ELSE
JBCMPZ( 2: 2 ) = 'N'
END IF
*
* ==== NWR = recommended deflation window size. At this
* . point, N .GT. NTINY = 11, so there is enough
* . subdiagonal workspace for NWR.GE.2 as required.
* . (In fact, there is enough subdiagonal space for
* . NWR.GE.3.) ====
*
NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NWR = MAX( 2, NWR )
NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
*
* ==== NSR = recommended number of simultaneous shifts.
* . At this point N .GT. NTINY = 11, so there is at
* . enough subdiagonal workspace for NSR to be even
* . and greater than or equal to two as required. ====
*
NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
*
* ==== Estimate optimal workspace ====
*
* ==== Workspace query call to ZLAQR2 ====
*
CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
$ LDH, WORK, -1 )
*
* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ====
*
LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== ZLAHQR/ZLAQR0 crossover point ====
*
NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NMIN = MAX( NTINY, NMIN )
*
* ==== Nibble crossover point ====
*
NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
NIBBLE = MAX( 0, NIBBLE )
*
* ==== Accumulate reflections during ttswp? Use block
* . 2-by-2 structure during matrix-matrix multiply? ====
*
KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
KACC22 = MAX( 0, KACC22 )
KACC22 = MIN( 2, KACC22 )
*
* ==== NWMAX = the largest possible deflation window for
* . which there is sufficient workspace. ====
*
NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
NW = NWMAX
*
* ==== NSMAX = the Largest number of simultaneous shifts
* . for which there is sufficient workspace. ====
*
NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
NSMAX = NSMAX - MOD( NSMAX, 2 )
*
* ==== NDFL: an iteration count restarted at deflation. ====
*
NDFL = 1
*
* ==== ITMAX = iteration limit ====
*
ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
*
* ==== Last row and column in the active block ====
*
KBOT = IHI
*
* ==== Main Loop ====
*
DO 70 IT = 1, ITMAX
*
* ==== Done when KBOT falls below ILO ====
*
IF( KBOT.LT.ILO )
$ GO TO 80
*
* ==== Locate active block ====
*
DO 10 K = KBOT, ILO + 1, -1
IF( H( K, K-1 ).EQ.ZERO )
$ GO TO 20
10 CONTINUE
K = ILO
20 CONTINUE
KTOP = K
*
* ==== Select deflation window size:
* . Typical Case:
* . If possible and advisable, nibble the entire
* . active block. If not, use size MIN(NWR,NWMAX)
* . or MIN(NWR+1,NWMAX) depending upon which has
* . the smaller corresponding subdiagonal entry
* . (a heuristic).
* .
* . Exceptional Case:
* . If there have been no deflations in KEXNW or
* . more iterations, then vary the deflation window
* . size. At first, because, larger windows are,
* . in general, more powerful than smaller ones,
* . rapidly increase the window to the maximum possible.
* . Then, gradually reduce the window size. ====
*
NH = KBOT - KTOP + 1
NWUPBD = MIN( NH, NWMAX )
IF( NDFL.LT.KEXNW ) THEN
NW = MIN( NWUPBD, NWR )
ELSE
NW = MIN( NWUPBD, 2*NW )
END IF
IF( NW.LT.NWMAX ) THEN
IF( NW.GE.NH-1 ) THEN
NW = NH
ELSE
KWTOP = KBOT - NW + 1
IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
$ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
END IF
END IF
IF( NDFL.LT.KEXNW ) THEN
NDEC = -1
ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN
NDEC = NDEC + 1
IF( NW-NDEC.LT.2 )
$ NDEC = 0
NW = NW - NDEC
END IF
*
* ==== Aggressive early deflation:
* . split workspace under the subdiagonal into
* . - an nw-by-nw work array V in the lower
* . left-hand-corner,
* . - an NW-by-at-least-NW-but-more-is-better
* . (NW-by-NHO) horizontal work array along
* . the bottom edge,
* . - an at-least-NW-but-more-is-better (NHV-by-NW)
* . vertical work array along the left-hand-edge.
* . ====
*
KV = N - NW + 1
KT = NW + 1
NHO = ( N-NW-1 ) - KT + 1
KWV = NW + 2
NVE = ( N-NW ) - KWV + 1
*
* ==== Aggressive early deflation ====
*
CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
$ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
$ LWORK )
*
* ==== Adjust KBOT accounting for new deflations. ====
*
KBOT = KBOT - LD
*
* ==== KS points to the shifts. ====
*
KS = KBOT - LS + 1
*
* ==== Skip an expensive QR sweep if there is a (partly
* . heuristic) reason to expect that many eigenvalues
* . will deflate without it. Here, the QR sweep is
* . skipped if many eigenvalues have just been deflated
* . or if the remaining active block is small.
*
IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
$ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
*
* ==== NS = nominal number of simultaneous shifts.
* . This may be lowered (slightly) if ZLAQR2
* . did not provide that many shifts. ====
*
NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
NS = NS - MOD( NS, 2 )
*
* ==== If there have been no deflations
* . in a multiple of KEXSH iterations,
* . then try exceptional shifts.
* . Otherwise use shifts provided by
* . ZLAQR2 above or from the eigenvalues
* . of a trailing principal submatrix. ====
*
IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
KS = KBOT - NS + 1
DO 30 I = KBOT, KS + 1, -2
W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
W( I-1 ) = W( I )
30 CONTINUE
ELSE
*
* ==== Got NS/2 or fewer shifts? Use ZLAHQR
* . on a trailing principal submatrix to
* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
* . there is enough space below the subdiagonal
* . to fit an NS-by-NS scratch array.) ====
*
IF( KBOT-KS+1.LE.NS / 2 ) THEN
KS = KBOT - NS + 1
KT = N - NS + 1
CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
$ H( KT, 1 ), LDH )
CALL ZLAHQR( .false., .false., NS, 1, NS,
$ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM,
$ 1, INF )
KS = KS + INF
*
* ==== In case of a rare QR failure use
* . eigenvalues of the trailing 2-by-2
* . principal submatrix. Scale to avoid
* . overflows, underflows and subnormals.
* . (The scale factor S can not be zero,
* . because H(KBOT,KBOT-1) is nonzero.) ====
*
IF( KS.GE.KBOT ) THEN
S = CABS1( H( KBOT-1, KBOT-1 ) ) +
$ CABS1( H( KBOT, KBOT-1 ) ) +
$ CABS1( H( KBOT-1, KBOT ) ) +
$ CABS1( H( KBOT, KBOT ) )
AA = H( KBOT-1, KBOT-1 ) / S
CC = H( KBOT, KBOT-1 ) / S
BB = H( KBOT-1, KBOT ) / S
DD = H( KBOT, KBOT ) / S
TR2 = ( AA+DD ) / TWO
DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
RTDISC = SQRT( -DET )
W( KBOT-1 ) = ( TR2+RTDISC )*S
W( KBOT ) = ( TR2-RTDISC )*S
*
KS = KBOT - 1
END IF
END IF
*
IF( KBOT-KS+1.GT.NS ) THEN
*
* ==== Sort the shifts (Helps a little) ====
*
SORTED = .false.
DO 50 K = KBOT, KS + 1, -1
IF( SORTED )
$ GO TO 60
SORTED = .true.
DO 40 I = KS, K - 1
IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
$ THEN
SORTED = .false.
SWAP = W( I )
W( I ) = W( I+1 )
W( I+1 ) = SWAP
END IF
40 CONTINUE
50 CONTINUE
60 CONTINUE
END IF
END IF
*
* ==== If there are only two shifts, then use
* . only one. ====
*
IF( KBOT-KS+1.EQ.2 ) THEN
IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
$ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
W( KBOT-1 ) = W( KBOT )
ELSE
W( KBOT ) = W( KBOT-1 )
END IF
END IF
*
* ==== Use up to NS of the the smallest magnitude
* . shifts. If there aren't NS shifts available,
* . then use them all, possibly dropping one to
* . make the number of shifts even. ====
*
NS = MIN( NS, KBOT-KS+1 )
NS = NS - MOD( NS, 2 )
KS = KBOT - NS + 1
*
* ==== Small-bulge multi-shift QR sweep:
* . split workspace under the subdiagonal into
* . - a KDU-by-KDU work array U in the lower
* . left-hand-corner,
* . - a KDU-by-at-least-KDU-but-more-is-better
* . (KDU-by-NHo) horizontal work array WH along
* . the bottom edge,
* . - and an at-least-KDU-but-more-is-better-by-KDU
* . (NVE-by-KDU) vertical work WV arrow along
* . the left-hand-edge. ====
*
KDU = 3*NS - 3
KU = N - KDU + 1
KWH = KDU + 1
NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
KWV = KDU + 4
NVE = N - KDU - KWV + 1
*
* ==== Small-bulge multi-shift QR sweep ====
*
CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
$ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
$ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
$ NHO, H( KU, KWH ), LDH )
END IF
*
* ==== Note progress (or the lack of it). ====
*
IF( LD.GT.0 ) THEN
NDFL = 1
ELSE
NDFL = NDFL + 1
END IF
*
* ==== End of main loop ====
70 CONTINUE
*
* ==== Iteration limit exceeded. Set INFO to show where
* . the problem occurred and exit. ====
*
INFO = KBOT
80 CONTINUE
END IF
*
* ==== Return the optimal value of LWORK. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR4 ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr5.f 0000644 0000000 0000000 00000000132 14061636515 015242 x ustar 00 30 mtime=1623670093.402103896
30 atime=1623670093.401103897
30 ctime=1623670093.402103896
elk-7.2.42/src/LAPACK/zlaqr5.f 0000644 0025044 0025044 00000101451 14061636515 017301 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR5 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
* H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
* WV, LDWV, NH, WH, LDWH )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
* $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR5, called by ZLAQR0, performs a
*> single small-bulge multi-shift QR sweep.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> WANTT = .true. if the triangular Schur factor
*> is being computed. WANTT is set to .false. otherwise.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> WANTZ = .true. if the unitary Schur factor is being
*> computed. WANTZ is set to .false. otherwise.
*> \endverbatim
*>
*> \param[in] KACC22
*> \verbatim
*> KACC22 is INTEGER with value 0, 1, or 2.
*> Specifies the computation mode of far-from-diagonal
*> orthogonal updates.
*> = 0: ZLAQR5 does not accumulate reflections and does not
*> use matrix-matrix multiply to update far-from-diagonal
*> matrix entries.
*> = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
*> multiply to update the far-from-diagonal matrix entries.
*> = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
*> multiply to update the far-from-diagonal matrix entries,
*> and takes advantage of 2-by-2 block structure during
*> matrix multiplies.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> N is the order of the Hessenberg matrix H upon which this
*> subroutine operates.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> These are the first and last rows and columns of an
*> isolated diagonal block upon which the QR sweep is to be
*> applied. It is assumed without a check that
*> either KTOP = 1 or H(KTOP,KTOP-1) = 0
*> and
*> either KBOT = N or H(KBOT+1,KBOT) = 0.
*> \endverbatim
*>
*> \param[in] NSHFTS
*> \verbatim
*> NSHFTS is INTEGER
*> NSHFTS gives the number of simultaneous shifts. NSHFTS
*> must be positive and even.
*> \endverbatim
*>
*> \param[in,out] S
*> \verbatim
*> S is COMPLEX*16 array, dimension (NSHFTS)
*> S contains the shifts of origin that define the multi-
*> shift QR sweep. On output S may be reordered.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input H contains a Hessenberg matrix. On output a
*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
*> to the isolated diagonal block in rows and columns KTOP
*> through KBOT.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> LDH is the leading dimension of H just as declared in the
*> calling procedure. LDH >= MAX(1,N).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,IHIZ)
*> If WANTZ = .TRUE., then the QR Sweep unitary
*> similarity transformation is accumulated into
*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
*> If WANTZ = .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> LDA is the leading dimension of Z just as declared in
*> the calling procedure. LDZ >= N.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NSHFTS/2)
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> LDV is the leading dimension of V as declared in the
*> calling procedure. LDV >= 3.
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*> U is COMPLEX*16 array, dimension (LDU,3*NSHFTS-3)
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*> LDU is INTEGER
*> LDU is the leading dimension of U just as declared in the
*> in the calling subroutine. LDU >= 3*NSHFTS-3.
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> NV is the number of rows in WV agailable for workspace.
*> NV >= 1.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,3*NSHFTS-3)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> LDWV is the leading dimension of WV as declared in the
*> in the calling subroutine. LDWV >= NV.
*> \endverbatim
*
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> NH is the number of columns in array WH available for
*> workspace. NH >= 1.
*> \endverbatim
*>
*> \param[out] WH
*> \verbatim
*> WH is COMPLEX*16 array, dimension (LDWH,NH)
*> \endverbatim
*>
*> \param[in] LDWH
*> \verbatim
*> LDWH is INTEGER
*> Leading dimension of WH just as declared in the
*> calling procedure. LDWH >= 3*NSHFTS-3.
*> \endverbatim
*>
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*
*> \par References:
* ================
*>
*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages
*> 929--947, 2002.
*>
* =====================================================================
SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
$ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
$ WV, LDWV, NH, WH, LDWH )
*
* -- LAPACK auxiliary routine (version 3.7.1) --
* -- 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 IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
$ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
$ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 ALPHA, BETA, CDUM, REFSUM
DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
$ SMLNUM, TST1, TST2, ULP
INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
$ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
$ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
$ NS, NU
LOGICAL ACCUM, BLK22, BMP22
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
*
INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
* ..
* .. Local Arrays ..
COMPLEX*16 VT( 3 )
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET,
$ ZTRMM
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== If there are no shifts, then there is nothing to do. ====
*
IF( NSHFTS.LT.2 )
$ RETURN
*
* ==== If the active block is empty or 1-by-1, then there
* . is nothing to do. ====
*
IF( KTOP.GE.KBOT )
$ RETURN
*
* ==== NSHFTS is supposed to be even, but if it is odd,
* . then simply reduce it by one. ====
*
NS = NSHFTS - MOD( NSHFTS, 2 )
*
* ==== Machine constants for deflation ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Use accumulated reflections to update far-from-diagonal
* . entries ? ====
*
ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
*
* ==== If so, exploit the 2-by-2 block structure? ====
*
BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
*
* ==== clear trash ====
*
IF( KTOP+2.LE.KBOT )
$ H( KTOP+2, KTOP ) = ZERO
*
* ==== NBMPS = number of 2-shift bulges in the chain ====
*
NBMPS = NS / 2
*
* ==== KDU = width of slab ====
*
KDU = 6*NBMPS - 3
*
* ==== Create and chase chains of NBMPS bulges ====
*
DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
NDCOL = INCOL + KDU
IF( ACCUM )
$ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
*
* ==== Near-the-diagonal bulge chase. The following loop
* . performs the near-the-diagonal part of a small bulge
* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
* . chunk extends from column INCOL to column NDCOL
* . (including both column INCOL and column NDCOL). The
* . following loop chases a 3*NBMPS column long chain of
* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
* . may be less than KTOP and and NDCOL may be greater than
* . KBOT indicating phantom columns from which to chase
* . bulges before they are actually introduced or to which
* . to chase bulges beyond column KBOT.) ====
*
DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
*
* ==== Bulges number MTOP to MBOT are active double implicit
* . shift bulges. There may or may not also be small
* . 2-by-2 bulge, if there is room. The inactive bulges
* . (if any) must wait until the active bulges have moved
* . down the diagonal to make room. The phantom matrix
* . paradigm described above helps keep track. ====
*
MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
M22 = MBOT + 1
BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
$ ( KBOT-2 )
*
* ==== Generate reflections to chase the chain right
* . one column. (The minimum value of K is KTOP-1.) ====
*
DO 10 M = MTOP, MBOT
K = KRCOL + 3*( M-1 )
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
$ S( 2*M ), V( 1, M ) )
ALPHA = V( 1, M )
CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
ELSE
BETA = H( K+1, K )
V( 2, M ) = H( K+2, K )
V( 3, M ) = H( K+3, K )
CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
*
* ==== A Bulge may collapse because of vigilant
* . deflation or destructive underflow. In the
* . underflow case, try the two-small-subdiagonals
* . trick to try to reinflate the bulge. ====
*
IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE.
$ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN
*
* ==== Typical case: not collapsed (yet). ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Atypical case: collapsed. Attempt to
* . reintroduce ignoring H(K+1,K) and H(K+2,K).
* . If the fill resulting from the new
* . reflector is too large, then abandon it.
* . Otherwise, use the new one. ====
*
CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ),
$ S( 2*M ), VT )
ALPHA = VT( 1 )
CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = DCONJG( VT( 1 ) )*
$ ( H( K+1, K )+DCONJG( VT( 2 ) )*
$ H( K+2, K ) )
*
IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP*
$ ( CABS1( H( K, K ) )+CABS1( H( K+1,
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
*
* ==== Starting a new bulge here would
* . create non-negligible fill. Use
* . the old one with trepidation. ====
*
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
ELSE
*
* ==== Stating a new bulge here would
* . create only negligible fill.
* . Replace the old reflector with
* . the new one. ====
*
H( K+1, K ) = H( K+1, K ) - REFSUM
H( K+2, K ) = ZERO
H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 )
V( 2, M ) = VT( 2 )
V( 3, M ) = VT( 3 )
END IF
END IF
END IF
10 CONTINUE
*
* ==== Generate a 2-by-2 reflection, if needed. ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF( K.EQ.KTOP-1 ) THEN
CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
$ S( 2*M22 ), V( 1, M22 ) )
BETA = V( 1, M22 )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
ELSE
BETA = H( K+1, K )
V( 2, M22 ) = H( K+2, K )
CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
H( K+1, K ) = BETA
H( K+2, K ) = ZERO
END IF
END IF
*
* ==== Multiply H by reflections from the left ====
*
IF( ACCUM ) THEN
JBOT = MIN( NDCOL, KBOT )
ELSE IF( WANTT ) THEN
JBOT = N
ELSE
JBOT = KBOT
END IF
DO 30 J = MAX( KTOP, KRCOL ), JBOT
MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
DO 20 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = DCONJG( V( 1, M ) )*
$ ( H( K+1, J )+DCONJG( V( 2, M ) )*
$ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
20 CONTINUE
30 CONTINUE
IF( BMP22 ) THEN
K = KRCOL + 3*( M22-1 )
DO 40 J = MAX( K+1, KTOP ), JBOT
REFSUM = DCONJG( V( 1, M22 ) )*
$ ( H( K+1, J )+DCONJG( V( 2, M22 ) )*
$ H( K+2, J ) )
H( K+1, J ) = H( K+1, J ) - REFSUM
H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
40 CONTINUE
END IF
*
* ==== Multiply H by reflections from the right.
* . Delay filling in the last row until the
* . vigilant deflation check is complete. ====
*
IF( ACCUM ) THEN
JTOP = MAX( KTOP, INCOL )
ELSE IF( WANTT ) THEN
JTOP = 1
ELSE
JTOP = KTOP
END IF
DO 80 M = MTOP, MBOT
IF( V( 1, M ).NE.ZERO ) THEN
K = KRCOL + 3*( M-1 )
DO 50 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
$ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
H( J, K+3 ) = H( J, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
50 CONTINUE
*
IF( ACCUM ) THEN
*
* ==== Accumulate U. (If necessary, update Z later
* . with with an efficient matrix-matrix
* . multiply.) ====
*
KMS = K - INCOL
DO 60 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
$ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
U( J, KMS+3 ) = U( J, KMS+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
60 CONTINUE
ELSE IF( WANTZ ) THEN
*
* ==== U is not accumulated, so update Z
* . now by multiplying by reflections
* . from the right. ====
*
DO 70 J = ILOZ, IHIZ
REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
$ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M ) )
Z( J, K+3 ) = Z( J, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
70 CONTINUE
END IF
END IF
80 CONTINUE
*
* ==== Special case: 2-by-2 reflection (if needed) ====
*
K = KRCOL + 3*( M22-1 )
IF( BMP22 ) THEN
IF ( V( 1, M22 ).NE.ZERO ) THEN
DO 90 J = JTOP, MIN( KBOT, K+3 )
REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
$ H( J, K+2 ) )
H( J, K+1 ) = H( J, K+1 ) - REFSUM
H( J, K+2 ) = H( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
90 CONTINUE
*
IF( ACCUM ) THEN
KMS = K - INCOL
DO 100 J = MAX( 1, KTOP-INCOL ), KDU
REFSUM = V( 1, M22 )*( U( J, KMS+1 )+
$ V( 2, M22 )*U( J, KMS+2 ) )
U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
U( J, KMS+2 ) = U( J, KMS+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
100 CONTINUE
ELSE IF( WANTZ ) THEN
DO 110 J = ILOZ, IHIZ
REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
$ Z( J, K+2 ) )
Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
Z( J, K+2 ) = Z( J, K+2 ) -
$ REFSUM*DCONJG( V( 2, M22 ) )
110 CONTINUE
END IF
END IF
END IF
*
* ==== Vigilant deflation check ====
*
MSTART = MTOP
IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
$ MSTART = MSTART + 1
MEND = MBOT
IF( BMP22 )
$ MEND = MEND + 1
IF( KRCOL.EQ.KBOT-2 )
$ MEND = MEND + 1
DO 120 M = MSTART, MEND
K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
*
* ==== The following convergence test requires that
* . the tradition small-compared-to-nearby-diagonals
* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
* . criteria both be satisfied. The latter improves
* . accuracy in some examples. Falling back on an
* . alternate convergence criterion when TST1 or TST2
* . is zero (as done here) is traditional but probably
* . unnecessary. ====
*
IF( H( K+1, K ).NE.ZERO ) THEN
TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
IF( TST1.EQ.RZERO ) THEN
IF( K.GE.KTOP+1 )
$ TST1 = TST1 + CABS1( H( K, K-1 ) )
IF( K.GE.KTOP+2 )
$ TST1 = TST1 + CABS1( H( K, K-2 ) )
IF( K.GE.KTOP+3 )
$ TST1 = TST1 + CABS1( H( K, K-3 ) )
IF( K.LE.KBOT-2 )
$ TST1 = TST1 + CABS1( H( K+2, K+1 ) )
IF( K.LE.KBOT-3 )
$ TST1 = TST1 + CABS1( H( K+3, K+1 ) )
IF( K.LE.KBOT-4 )
$ TST1 = TST1 + CABS1( H( K+4, K+1 ) )
END IF
IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
$ THEN
H12 = MAX( CABS1( H( K+1, K ) ),
$ CABS1( H( K, K+1 ) ) )
H21 = MIN( CABS1( H( K+1, K ) ),
$ CABS1( H( K, K+1 ) ) )
H11 = MAX( CABS1( H( K+1, K+1 ) ),
$ CABS1( H( K, K )-H( K+1, K+1 ) ) )
H22 = MIN( CABS1( H( K+1, K+1 ) ),
$ CABS1( H( K, K )-H( K+1, K+1 ) ) )
SCL = H11 + H12
TST2 = H22*( H11 / SCL )
*
IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE.
$ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
END IF
END IF
120 CONTINUE
*
* ==== Fill in the last row of each bulge. ====
*
MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
DO 130 M = MTOP, MEND
K = KRCOL + 3*( M-1 )
REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
H( K+4, K+1 ) = -REFSUM
H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
H( K+4, K+3 ) = H( K+4, K+3 ) -
$ REFSUM*DCONJG( V( 3, M ) )
130 CONTINUE
*
* ==== End of near-the-diagonal bulge chase. ====
*
140 CONTINUE
*
* ==== Use U (if accumulated) to update far-from-diagonal
* . entries in H. If required, use U to update Z as
* . well. ====
*
IF( ACCUM ) THEN
IF( WANTT ) THEN
JTOP = 1
JBOT = N
ELSE
JTOP = KTOP
JBOT = KBOT
END IF
IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
$ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
*
* ==== Updates not exploiting the 2-by-2 block
* . structure of U. K1 and NU keep track of
* . the location and size of U in the special
* . cases of introducing bulges and chasing
* . bulges off the bottom. In these special
* . cases and in case the number of shifts
* . is NS = 2, there is no 2-by-2 block
* . structure to exploit. ====
*
K1 = MAX( 1, KTOP-INCOL )
NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
*
* ==== Horizontal Multiply ====
*
DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
$ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
$ LDWH )
CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH,
$ H( INCOL+K1, JCOL ), LDH )
150 CONTINUE
*
* ==== Vertical multiply ====
*
DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ H( JROW, INCOL+K1 ), LDH )
160 CONTINUE
*
* ==== Z multiply (also vertical) ====
*
IF( WANTZ ) THEN
DO 170 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
$ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
$ LDU, ZERO, WV, LDWV )
CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
$ Z( JROW, INCOL+K1 ), LDZ )
170 CONTINUE
END IF
ELSE
*
* ==== Updates exploiting U's 2-by-2 block structure.
* . (I2, I4, J2, J4 are the last rows and columns
* . of the blocks.) ====
*
I2 = ( KDU+1 ) / 2
I4 = KDU
J2 = I4 - I2
J4 = KDU
*
* ==== KZS and KNZ deal with the band of zeros
* . along the diagonal of one of the triangular
* . blocks. ====
*
KZS = ( J4-J2 ) - ( NS+1 )
KNZ = NS + 1
*
* ==== Horizontal multiply ====
*
DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
JLEN = MIN( NH, JBOT-JCOL+1 )
*
* ==== Copy bottom of H to top+KZS of scratch ====
* (The first KZS rows get multiplied by zero.) ====
*
CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
$ LDH, WH( KZS+1, 1 ), LDWH )
*
* ==== Multiply by U21**H ====
*
CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
$ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
$ LDWH )
*
* ==== Multiply top of H by U11**H ====
*
CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
$ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
*
* ==== Copy top of H to bottom of WH ====
*
CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U21**H ====
*
CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
$ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
$ U( J2+1, I2+1 ), LDU,
$ H( INCOL+1+J2, JCOL ), LDH, ONE,
$ WH( I2+1, 1 ), LDWH )
*
* ==== Copy it back ====
*
CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH,
$ H( INCOL+1, JCOL ), LDH )
180 CONTINUE
*
* ==== Vertical multiply ====
*
DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
*
* ==== Copy right of H to scratch (the first KZS
* . columns get multiplied by zero) ====
*
CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
$ LDH, WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
$ LDWV )
*
* ==== Copy left of H to right of scratch ====
*
CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ H( JROW, INCOL+1+J2 ), LDH,
$ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Copy it back ====
*
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ H( JROW, INCOL+1 ), LDH )
190 CONTINUE
*
* ==== Multiply Z (also vertical) ====
*
IF( WANTZ ) THEN
DO 200 JROW = ILOZ, IHIZ, NV
JLEN = MIN( NV, IHIZ-JROW+1 )
*
* ==== Copy right of Z to left of scratch (first
* . KZS columns get multiplied by zero) ====
*
CALL ZLACPY( 'ALL', JLEN, KNZ,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ WV( 1, 1+KZS ), LDWV )
*
* ==== Multiply by U12 ====
*
CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
$ LDWV )
CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
$ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
$ LDWV )
*
* ==== Multiply by U11 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
$ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
$ WV, LDWV )
*
* ==== Copy left of Z to right of scratch ====
*
CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
$ LDZ, WV( 1, 1+I2 ), LDWV )
*
* ==== Multiply by U21 ====
*
CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
$ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
$ LDWV )
*
* ==== Multiply by U22 ====
*
CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
$ Z( JROW, INCOL+1+J2 ), LDZ,
$ U( J2+1, I2+1 ), LDU, ONE,
$ WV( 1, 1+I2 ), LDWV )
*
* ==== Copy the result back to Z ====
*
CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
$ Z( JROW, INCOL+1 ), LDZ )
200 CONTINUE
END IF
END IF
END IF
210 CONTINUE
*
* ==== End of ZLAQR5 ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ilazlc.f 0000644 0000000 0000000 00000000132 14061636515 015302 x ustar 00 30 mtime=1623670093.404103894
30 atime=1623670093.404103894
30 ctime=1623670093.404103894
elk-7.2.42/src/LAPACK/ilazlc.f 0000644 0025044 0025044 00000005657 14061636515 017354 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ILAZLC scans a matrix for its last non-zero column.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLC( M, N, 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILAZLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILAZLC = N, 1, -1
DO I = 1, M
IF( A(I, ILAZLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ilazlr.f 0000644 0000000 0000000 00000000132 14061636515 015321 x ustar 00 30 mtime=1623670093.406103893
30 atime=1623670093.406103893
30 ctime=1623670093.406103893
elk-7.2.42/src/LAPACK/ilazlr.f 0000644 0025044 0025044 00000005742 14061636515 017366 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ILAZLR scans a matrix for its last non-zero row.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILAZLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILAZLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILAZLR( M, N, 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILAZLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILAZLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILAZLR = MAX( ILAZLR, I )
END DO
END IF
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlapy3.f 0000644 0000000 0000000 00000000132 14061636515 015220 x ustar 00 30 mtime=1623670093.408103891
30 atime=1623670093.407103892
30 ctime=1623670093.408103891
elk-7.2.42/src/LAPACK/dlapy3.f 0000644 0025044 0025044 00000005266 14061636515 017266 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAPY3 returns sqrt(x2+y2+z2).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION X, Y, Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
*> unnecessary overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION
*> 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
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY3( 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 ..
DOUBLE PRECISION X, Y, Z
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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.
DLAPY3 = XABS + YABS + ZABS
ELSE
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of DLAPY3
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunml2.f 0000644 0000000 0000000 00000000127 14061636515 015257 x ustar 00 29 mtime=1623670093.40910389
29 atime=1623670093.40910389
29 ctime=1623670093.40910389
elk-7.2.42/src/LAPACK/zunml2.f 0000644 0025044 0025044 00000017050 14061636515 017313 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNML2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNML2 overwrites the general complex m-by-n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**H if SIDE = 'R' and TRANS = 'C',
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k)**H . . . H(2)**H H(1)**H
*>
*> as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left
*> = 'R': apply Q or Q**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L',
*> (LDA,N) if SIDE = 'R'
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGELQF in the first k rows of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,K).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGELQF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m-by-n matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLACGV, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNML2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = DCONJG( TAU( I ) )
ELSE
TAUI = TAU( I )
END IF
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
AII = A( I, I )
A( I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
$ LDC, WORK )
A( I, I ) = AII
IF( I.LT.NQ )
$ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
10 CONTINUE
RETURN
*
* End of ZUNML2
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunm2l.f 0000644 0000000 0000000 00000000132 14061636515 015253 x ustar 00 30 mtime=1623670093.411103888
30 atime=1623670093.411103888
30 ctime=1623670093.411103888
elk-7.2.42/src/LAPACK/zunm2l.f 0000644 0025044 0025044 00000016423 14061636515 017316 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNM2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNM2L overwrites the general complex m-by-n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**H if SIDE = 'R' and TRANS = 'C',
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left
*> = 'R': apply Q or Q**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQLF in the last k columns of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m-by-n matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNM2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* End of ZUNM2L
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunm2r.f 0000644 0000000 0000000 00000000132 14061636515 015261 x ustar 00 30 mtime=1623670093.413103886
30 atime=1623670093.413103886
30 ctime=1623670093.413103886
elk-7.2.42/src/LAPACK/zunm2r.f 0000644 0025044 0025044 00000016552 14061636515 017327 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNM2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNM2R overwrites the general complex m-by-n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**H* C if SIDE = 'L' and TRANS = 'C', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**H if SIDE = 'R' and TRANS = 'C',
*>
*> where Q is a complex unitary matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left
*> = 'R': apply Q or Q**H from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> ZGEQRF in the first k columns of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the m-by-n matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
COMPLEX*16 AII, TAUI
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNM2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) or H(i)**H is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) or H(i)**H is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i) or H(i)**H
*
IF( NOTRAN ) THEN
TAUI = TAU( I )
ELSE
TAUI = DCONJG( TAU( I ) )
END IF
AII = A( I, I )
A( I, I ) = ONE
CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
$ WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of ZUNM2R
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed5.f 0000644 0000000 0000000 00000000132 14061636515 015162 x ustar 00 30 mtime=1623670093.415103884
30 atime=1623670093.414103885
30 ctime=1623670093.415103884
elk-7.2.42/src/LAPACK/dlaed5.f 0000644 0025044 0025044 00000012373 14061636515 017225 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED5 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 DLAED5 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
*
* .. Scalar Arguments ..
* INTEGER I
* DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (2)
*> The original eigenvalues. We assume D(1) < D(2).
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (2)
*> The components of the updating vector.
*> \endverbatim
*>
*> \param[out] DELTA
*> \verbatim
*> DELTA is DOUBLE PRECISION array, dimension (2)
*> The vector DELTA contains the information necessary
*> to construct the eigenvectors.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> The scalar in the symmetric updating formula.
*> \endverbatim
*>
*> \param[out] DLAM
*> \verbatim
*> DLAM is DOUBLE PRECISION
*> 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 DLAED5( 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
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION 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 DLAED5
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed7.f 0000644 0000000 0000000 00000000132 14061636515 015164 x ustar 00 30 mtime=1623670093.417103882
30 atime=1623670093.416103883
30 ctime=1623670093.417103882
elk-7.2.42/src/LAPACK/dlaed7.f 0000644 0025044 0025044 00000031723 14061636515 017227 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED7 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 DLAED7 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED7( 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
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
* $ QSTORE( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED7 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. DLAED1 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 DLAED8.
*>
*> The second stage consists of calculating the updated
*> eigenvalues. This is done by finding the roots of the secular
*> equation via the routine DLAED4 (as called by DLAED9).
*> 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 DOUBLE PRECISION array, dimension (N)
*> On entry, the eigenvalues of the rank-1-perturbed matrix.
*> On exit, the eigenvalues of the repaired matrix.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is DOUBLE PRECISION 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 DOUBLE PRECISION
*> 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 DOUBLE PRECISION array, dimension (N**2+1)
*> Stores eigenvectors of submatrices encountered during
*> divide and conquer, packed together. QPTR points to
*> beginning of the submatrices.
*> \endverbatim
*>
*> \param[in,out] QPTR
*> \verbatim
*> QPTR is INTEGER array, dimension (N+2)
*> List of indices pointing to beginning of submatrices stored
*> in QSTORE. The submatrices are numbered starting at the
*> bottom left of the divide and conquer tree, from left to
*> right and bottom to top.
*> \endverbatim
*>
*> \param[in] PRMPTR
*> \verbatim
*> PRMPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in PERM a
*> level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
*> indicates the size of the permutation and also the size of
*> the full, non-deflated problem.
*> \endverbatim
*>
*> \param[in] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N lg N)
*> Contains the permutations (from deflation and sorting) to be
*> applied to each eigenblock.
*> \endverbatim
*>
*> \param[in] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER array, dimension (N lg N)
*> Contains a list of pointers which indicate where in GIVCOL a
*> level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
*> indicates the number of Givens rotations.
*> \endverbatim
*>
*> \param[in] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension (2, N lg N)
*> Each pair of numbers indicates a pair of columns to take place
*> in a Givens rotation.
*> \endverbatim
*>
*> \param[in] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION 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 DLAED7( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
$ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
$ QSTORE( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
$ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, 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( 'DLAED7', -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 DLAED8 and DLAED9.
*
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 DLAEDA( 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 DLAED8( 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 DLAED9( 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 DGEMM( '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 DLAMRG( N1, N2, D, 1, -1, INDXQ )
ELSE
QPTR( CURR+1 ) = QPTR( CURR )
DO 20 I = 1, N
INDXQ( I ) = I
20 CONTINUE
END IF
*
30 CONTINUE
RETURN
*
* End of DLAED7
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq3.f 0000644 0000000 0000000 00000000132 14061636515 015213 x ustar 00 30 mtime=1623670093.419103881
30 atime=1623670093.418103881
30 ctime=1623670093.419103881
elk-7.2.42/src/LAPACK/dlasq3.f 0000644 0025044 0025044 00000024743 14061636515 017262 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
* ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
* DN2, G, TAU )
*
* .. Scalar Arguments ..
* LOGICAL IEEE
* INTEGER I0, ITER, N0, NDIV, NFAIL, PP
* DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
* $ QMAX, SIGMA, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
*> In case of failure it changes shifts, and tries again until output
*> is positive.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] I0
*> \verbatim
*> I0 is INTEGER
*> First index.
*> \endverbatim
*>
*> \param[in,out] N0
*> \verbatim
*> N0 is INTEGER
*> Last index.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( 4*N0 )
*> Z holds the qd array.
*> \endverbatim
*>
*> \param[in,out] PP
*> \verbatim
*> PP is INTEGER
*> PP=0 for ping, PP=1 for pong.
*> PP=2 indicates that flipping was applied to the Z array
*> and that the initial tests for deflation should not be
*> performed.
*> \endverbatim
*>
*> \param[out] DMIN
*> \verbatim
*> DMIN is DOUBLE PRECISION
*> Minimum value of d.
*> \endverbatim
*>
*> \param[out] SIGMA
*> \verbatim
*> SIGMA is DOUBLE PRECISION
*> Sum of shifts used in current segment.
*> \endverbatim
*>
*> \param[in,out] DESIG
*> \verbatim
*> DESIG is DOUBLE PRECISION
*> Lower order part of SIGMA
*> \endverbatim
*>
*> \param[in] QMAX
*> \verbatim
*> QMAX is DOUBLE PRECISION
*> Maximum value of q.
*> \endverbatim
*>
*> \param[in,out] NFAIL
*> \verbatim
*> NFAIL is INTEGER
*> Increment NFAIL by 1 each time the shift was too big.
*> \endverbatim
*>
*> \param[in,out] ITER
*> \verbatim
*> ITER is INTEGER
*> Increment ITER by 1 for each iteration.
*> \endverbatim
*>
*> \param[in,out] NDIV
*> \verbatim
*> NDIV is INTEGER
*> Increment NDIV by 1 for each division.
*> \endverbatim
*>
*> \param[in] IEEE
*> \verbatim
*> IEEE is LOGICAL
*> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
*> \endverbatim
*>
*> \param[in,out] TTYPE
*> \verbatim
*> TTYPE is INTEGER
*> Shift type.
*> \endverbatim
*>
*> \param[in,out] DMIN1
*> \verbatim
*> DMIN1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DMIN2
*> \verbatim
*> DMIN2 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DN
*> \verbatim
*> DN is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DN1
*> \verbatim
*> DN1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DN2
*> \verbatim
*> DN2 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] G
*> \verbatim
*> G is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*>
*> These are passed as arguments in order to save their values
*> between calls to DLASQ3.
*> \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 DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
$ DN2, G, TAU )
*
* -- 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 ..
LOGICAL IEEE
INTEGER I0, ITER, N0, NDIV, NFAIL, PP
DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
$ QMAX, SIGMA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CBIAS
PARAMETER ( CBIAS = 1.50D0 )
DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
$ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER IPN4, J4, N0IN, NN, TTYPE
DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2
* ..
* .. External Subroutines ..
EXTERNAL DLASQ4, DLASQ5, DLASQ6
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
LOGICAL DISNAN
EXTERNAL DISNAN, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
N0IN = N0
EPS = DLAMCH( 'Precision' )
TOL = EPS*HUNDRD
TOL2 = TOL**2
*
* Check for deflation.
*
10 CONTINUE
*
IF( N0.LT.I0 )
$ RETURN
IF( N0.EQ.I0 )
$ GO TO 20
NN = 4*N0 + PP
IF( N0.EQ.( I0+1 ) )
$ GO TO 40
*
* Check whether E(N0-1) is negligible, 1 eigenvalue.
*
IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
$ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
$ GO TO 30
*
20 CONTINUE
*
Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
N0 = N0 - 1
GO TO 10
*
* Check whether E(N0-2) is negligible, 2 eigenvalues.
*
30 CONTINUE
*
IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
$ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
$ GO TO 50
*
40 CONTINUE
*
IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
S = Z( NN-3 )
Z( NN-3 ) = Z( NN-7 )
Z( NN-7 ) = S
END IF
T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN
S = Z( NN-3 )*( Z( NN-5 ) / T )
IF( S.LE.T ) THEN
S = Z( NN-3 )*( Z( NN-5 ) /
$ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
ELSE
S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
END IF
T = Z( NN-7 ) + ( S+Z( NN-5 ) )
Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
Z( NN-7 ) = T
END IF
Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
N0 = N0 - 2
GO TO 10
*
50 CONTINUE
IF( PP.EQ.2 )
$ PP = 0
*
* Reverse the qd-array, if warranted.
*
IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
IPN4 = 4*( I0+N0 )
DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
TEMP = Z( J4-3 )
Z( J4-3 ) = Z( IPN4-J4-3 )
Z( IPN4-J4-3 ) = TEMP
TEMP = Z( J4-2 )
Z( J4-2 ) = Z( IPN4-J4-2 )
Z( IPN4-J4-2 ) = TEMP
TEMP = Z( J4-1 )
Z( J4-1 ) = Z( IPN4-J4-5 )
Z( IPN4-J4-5 ) = TEMP
TEMP = Z( J4 )
Z( J4 ) = Z( IPN4-J4-4 )
Z( IPN4-J4-4 ) = TEMP
60 CONTINUE
IF( N0-I0.LE.4 ) THEN
Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
Z( 4*N0-PP ) = Z( 4*I0-PP )
END IF
DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
$ Z( 4*I0+PP+3 ) )
Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
$ Z( 4*I0-PP+4 ) )
QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
DMIN = -ZERO
END IF
END IF
*
* Choose a shift.
*
CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
$ DN2, TAU, TTYPE, G )
*
* Call dqds until DMIN > 0.
*
70 CONTINUE
*
CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, IEEE, EPS )
*
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
*
* Check status.
*
IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN
*
* Success.
*
GO TO 90
*
ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
$ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
$ ABS( DN ).LT.TOL*SIGMA ) THEN
*
* Convergence hidden by negative DN.
*
Z( 4*( N0-1 )-PP+2 ) = ZERO
DMIN = ZERO
GO TO 90
ELSE IF( DMIN.LT.ZERO ) THEN
*
* TAU too big. Select new TAU and try again.
*
NFAIL = NFAIL + 1
IF( TTYPE.LT.-22 ) THEN
*
* Failed twice. Play it safe.
*
TAU = ZERO
ELSE IF( DMIN1.GT.ZERO ) THEN
*
* Late failure. Gives excellent shift.
*
TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
TTYPE = TTYPE - 11
ELSE
*
* Early failure. Divide by 4.
*
TAU = QURTR*TAU
TTYPE = TTYPE - 12
END IF
GO TO 70
ELSE IF( DISNAN( DMIN ) ) THEN
*
* NaN.
*
IF( TAU.EQ.ZERO ) THEN
GO TO 80
ELSE
TAU = ZERO
GO TO 70
END IF
ELSE
*
* Possible underflow. Play it safe.
*
GO TO 80
END IF
*
* Risk of underflow.
*
80 CONTINUE
CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
NDIV = NDIV + ( N0-I0+2 )
ITER = ITER + 1
TAU = ZERO
*
90 CONTINUE
IF( TAU.LT.SIGMA ) THEN
DESIG = DESIG + TAU
T = SIGMA + DESIG
DESIG = DESIG - ( T-SIGMA )
ELSE
T = SIGMA + TAU
DESIG = SIGMA - ( T-TAU ) + DESIG
END IF
SIGMA = T
*
RETURN
*
* End of DLASQ3
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlarf.f 0000644 0000000 0000000 00000000132 14061636515 015114 x ustar 00 30 mtime=1623670093.421103879
30 atime=1623670093.421103879
30 ctime=1623670093.421103879
elk-7.2.42/src/LAPACK/dlarf.f 0000644 0025044 0025044 00000014110 14061636515 017146 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLARF applies an elementary reflector to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARF applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \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 DOUBLE PRECISION 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 DOUBLE PRECISION
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- 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 SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
*
CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
*
CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of DLARF
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorm2l.f 0000644 0000000 0000000 00000000132 14061636515 015223 x ustar 00 30 mtime=1623670093.423103877
30 atime=1623670093.422103878
30 ctime=1623670093.423103877
elk-7.2.42/src/LAPACK/dorm2l.f 0000644 0025044 0025044 00000016221 14061636515 017262 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORM2L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORM2L( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORM2L overwrites the general real m by n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**T * C if SIDE = 'L' and TRANS = 'T', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**T if SIDE = 'R' and TRANS = 'T',
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(k) . . . H(2) H(1)
*>
*> as returned by DGEQLF. 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**T from the Left
*> = 'R': apply Q or Q**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'T': apply Q**T (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 DOUBLE PRECISION 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
*> DGEQLF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQLF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T 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 DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC 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, '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 .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( 'DORM2L', -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) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( NQ-K+I, I )
A( NQ-K+I, I ) = ONE
CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
$ WORK )
A( NQ-K+I, I ) = AII
10 CONTINUE
RETURN
*
* End of DORM2L
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dorm2r.f 0000644 0000000 0000000 00000000132 14061636515 015231 x ustar 00 30 mtime=1623670093.424103876
30 atime=1623670093.424103876
30 ctime=1623670093.424103876
elk-7.2.42/src/LAPACK/dorm2r.f 0000644 0025044 0025044 00000016322 14061636515 017272 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORM2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORM2R( 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 ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORM2R overwrites the general real m by n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**T* C if SIDE = 'L' and TRANS = 'T', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**T if SIDE = 'R' and TRANS = 'T',
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF. 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**T from the Left
*> = 'R': apply Q or Q**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'T': apply Q**T (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 DOUBLE PRECISION 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
*> DGEQRF 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 DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T 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 DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERcomputational
*
* =====================================================================
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ 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 SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC 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, '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 .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( 'DORM2R', -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) is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i)
*
AII = A( I, I )
A( I, I ) = ONE
CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
$ LDC, WORK )
A( I, I ) = AII
10 CONTINUE
RETURN
*
* End of DORM2R
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dladiv.f 0000644 0000000 0000000 00000000132 14061636515 015267 x ustar 00 30 mtime=1623670093.426103874
30 atime=1623670093.426103874
30 ctime=1623670093.426103874
elk-7.2.42/src/LAPACK/dladiv.f 0000644 0025044 0025044 00000013706 14061636515 017333 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLADIV 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 DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION
*> The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*> P is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is DOUBLE PRECISION
*> 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 doubleOTHERauxiliary
*
* =====================================================================
SUBROUTINE DLADIV( 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 ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION BS
PARAMETER ( BS = 2.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLADIV1
* ..
* .. 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.0D0
OV = DLAMCH( 'Overflow threshold' )
UN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( '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 DLADIV1(AA, BB, CC, DD, P, Q)
ELSE
CALL DLADIV1(BB, AA, DD, CC, P, Q)
Q = -Q
END IF
P = P * S
Q = Q * S
*
RETURN
*
* End of DLADIV
*
END
*> \ingroup doubleOTHERauxiliary
SUBROUTINE DLADIV1( 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 ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION R, T
* ..
* .. External Functions ..
DOUBLE PRECISION DLADIV2
EXTERNAL DLADIV2
* ..
* .. Executable Statements ..
*
R = D / C
T = ONE / (C + D * R)
P = DLADIV2(A, B, C, D, R, T)
A = -A
Q = DLADIV2(B, A, C, D, R, T)
*
RETURN
*
* End of DLADIV1
*
END
*> \ingroup doubleOTHERauxiliary
DOUBLE PRECISION FUNCTION DLADIV2( 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 ..
DOUBLE PRECISION A, B, C, D, R, T
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
*
* .. Local Scalars ..
DOUBLE PRECISION BR
* ..
* .. Executable Statements ..
*
IF( R.NE.ZERO ) THEN
BR = B * R
IF( BR.NE.ZERO ) THEN
DLADIV2 = (A + BR) * T
ELSE
DLADIV2 = A * T + (B * T) * R
END IF
ELSE
DLADIV2 = (A + D * (B / C)) * T
END IF
*
RETURN
*
* End of DLADIV12
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaeda.f 0000644 0000000 0000000 00000000132 14061636515 015236 x ustar 00 30 mtime=1623670093.428103872
30 atime=1623670093.428103872
30 ctime=1623670093.428103872
elk-7.2.42/src/LAPACK/dlaeda.f 0000644 0025044 0025044 00000023240 14061636515 017274 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAEDA 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 DLAEDA + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAEDA( 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( * )
* DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAEDA 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
* ==================
*>
*> Jeff Rutter, Computer Science Division, University of California
*> at Berkeley, USA
*
* =====================================================================
SUBROUTINE DLAEDA( 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( * )
DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
$ PTR, ZPTR1
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMV, DROT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, INT, 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( 'DLAEDA', -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( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
DO 10 K = 1, MID - BSIZ1 - 1
Z( K ) = ZERO
10 CONTINUE
CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
$ Z( MID-BSIZ1 ), 1 )
CALL DCOPY( 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 DROT( 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 DROT( 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( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
$ 1 ) ) ) )
IF( BSIZ1.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
$ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
END IF
CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
$ 1 )
IF( BSIZ2.GT.0 ) THEN
CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
$ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
END IF
CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
$ Z( MID+BSIZ2 ), 1 )
*
PTR = PTR + 2**( TLVLS-K )
70 CONTINUE
*
RETURN
*
* End of DLAEDA
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaed8.f 0000644 0000000 0000000 00000000127 14061636515 015217 x ustar 00 29 mtime=1623670093.43010387
29 atime=1623670093.43010387
29 ctime=1623670093.43010387
elk-7.2.42/src/LAPACK/zlaed8.f 0000644 0025044 0025044 00000035225 14061636515 017257 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAED8 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 ZLAED8 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
* Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
* GIVCOL, GIVNUM, INFO )
*
* .. Scalar Arguments ..
* INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
* $ INDXQ( * ), PERM( * )
* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
* $ Z( * )
* COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAED8 merges the two sets of eigenvalues together into a single
*> sorted set. Then it tries to deflate the size of the problem.
*> There are two ways in which deflation can occur: when two or more
*> eigenvalues are close together or if there is a tiny element in the
*> Z vector. For each such occurrence the order of the related secular
*> equation problem is reduced by one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[out] K
*> \verbatim
*> K is INTEGER
*> Contains the number of non-deflated eigenvalues.
*> This is the order of the related secular equation.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of the symmetric tridiagonal matrix. N >= 0.
*> \endverbatim
*>
*> \param[in] QSIZ
*> \verbatim
*> QSIZ is INTEGER
*> The dimension of the unitary matrix used to reduce
*> the dense or band matrix to tridiagonal form.
*> QSIZ >= N if ICOMPQ = 1.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, Q contains the eigenvectors of the partially solved
*> system which has been previously updated in matrix
*> multiplies with other partially solved eigensystems.
*> On exit, Q contains the trailing (N-K) updated eigenvectors
*> (those which were deflated) in its last N-K columns.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= max( 1, N ).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (N)
*> On entry, D contains the eigenvalues of the two submatrices to
*> be combined. On exit, D contains the trailing (N-K) updated
*> eigenvalues (those which were deflated) sorted into increasing
*> order.
*> \endverbatim
*>
*> \param[in,out] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> Contains the off diagonal element associated with the rank-1
*> cut which originally split the two submatrices which are now
*> being recombined. RHO is modified during the computation to
*> the value required by DLAED3.
*> \endverbatim
*>
*> \param[in] CUTPNT
*> \verbatim
*> CUTPNT is INTEGER
*> Contains the location of the last eigenvalue in the leading
*> sub-matrix. MIN(1,N) <= CUTPNT <= N.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (N)
*> On input this vector contains the updating vector (the last
*> row of the first sub-eigenvector matrix and the first row of
*> the second sub-eigenvector matrix). The contents of Z are
*> destroyed during the updating process.
*> \endverbatim
*>
*> \param[out] DLAMDA
*> \verbatim
*> DLAMDA is DOUBLE PRECISION array, dimension (N)
*> Contains a copy of the first K eigenvalues which will be used
*> by DLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is COMPLEX*16 array, dimension (LDQ2,N)
*> If ICOMPQ = 0, Q2 is not referenced. Otherwise,
*> Contains a copy of the first K eigenvectors which will be used
*> by DLAED7 in a matrix multiply (DGEMM) to update the new
*> eigenvectors.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of the array Q2. LDQ2 >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> This will hold the first k values of the final
*> deflation-altered z-vector and will be passed to DLAED3.
*> \endverbatim
*>
*> \param[out] INDXP
*> \verbatim
*> INDXP is INTEGER array, dimension (N)
*> This will contain the permutation used to place deflated
*> values of D at the end of the array. On output INDXP(1:K)
*> points to the nondeflated D-values and INDXP(K+1:N)
*> points to the deflated eigenvalues.
*> \endverbatim
*>
*> \param[out] INDX
*> \verbatim
*> INDX is INTEGER array, dimension (N)
*> This will contain the permutation used to sort the contents of
*> D into ascending order.
*> \endverbatim
*>
*> \param[in] INDXQ
*> \verbatim
*> INDXQ is INTEGER array, dimension (N)
*> This contains the permutation which separately sorts the two
*> sub-problems in D into ascending order. Note that elements in
*> the second half of this permutation must first have CUTPNT
*> added to their values in order to be accurate.
*> \endverbatim
*>
*> \param[out] PERM
*> \verbatim
*> PERM is INTEGER array, dimension (N)
*> Contains the permutations (from deflation and sorting) to be
*> applied to each eigenblock.
*> \endverbatim
*>
*> \param[out] GIVPTR
*> \verbatim
*> GIVPTR is INTEGER
*> Contains the number of Givens rotations which took place in
*> this subproblem.
*> \endverbatim
*>
*> \param[out] GIVCOL
*> \verbatim
*> GIVCOL is INTEGER array, dimension (2, N)
*> Each pair of numbers indicates a pair of columns to take place
*> in a Givens rotation.
*> \endverbatim
*>
*> \param[out] GIVNUM
*> \verbatim
*> GIVNUM is DOUBLE PRECISION array, dimension (2, N)
*> Each number indicates the S value to be used in the
*> corresponding Givens rotation.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
$ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
$ GIVCOL, GIVNUM, 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, INFO, K, LDQ, LDQ2, N, QSIZ
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
$ Z( * )
COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT,
$ ZLACPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( QSIZ.LT.N ) THEN
INFO = -3
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -5
ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
INFO = -8
ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
INFO = -12
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLAED8', -INFO )
RETURN
END IF
*
* Need to initialize GIVPTR to O here in case of quick exit
* to prevent an unspecified code behavior (usually sigfault)
* when IWORK array on entry to *stedc is not zeroed
* (or at least some IWORK entries which used in *laed7 for GIVPTR).
*
GIVPTR = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( 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 = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* -- except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
DO 50 J = 1, N
PERM( J ) = INDXQ( INDX( J ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
50 CONTINUE
CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )
RETURN
END IF
*
* If there are multiple eigenvalues then the problem deflates. Here
* the number of equal eigenvalues are found. As each equal
* eigenvalue is found, an elementary reflector is computed to rotate
* the corresponding eigensubspace so that the corresponding
* components of Z are zero in this new basis.
*
K = 0
K2 = N + 1
DO 60 J = 1, N
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
IF( J.EQ.N )
$ GO TO 100
ELSE
JLAM = J
GO TO 70
END IF
60 CONTINUE
70 CONTINUE
J = J + 1
IF( J.GT.N )
$ GO TO 90
IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
*
* Deflate due to small z component.
*
K2 = K2 - 1
INDXP( K2 ) = J
ELSE
*
* Check if eigenvalues are close enough to allow deflation.
*
S = Z( JLAM )
C = Z( J )
*
* Find sqrt(a**2+b**2) without overflow or
* destructive underflow.
*
TAU = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
$ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
T = D( JLAM )*C*C + D( J )*S*S
D( J ) = D( JLAM )*S*S + D( J )*C*C
D( JLAM ) = T
K2 = K2 - 1
I = 1
80 CONTINUE
IF( K2+I.LE.N ) THEN
IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
INDXP( K2+I-1 ) = INDXP( K2+I )
INDXP( K2+I ) = JLAM
I = I + 1
GO TO 80
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
ELSE
INDXP( K2+I-1 ) = JLAM
END IF
JLAM = J
ELSE
K = K + 1
W( K ) = Z( JLAM )
DLAMDA( 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 )
DLAMDA( K ) = D( JLAM )
INDXP( K ) = JLAM
*
100 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.
*
DO 110 J = 1, N
JP = INDXP( J )
DLAMDA( J ) = D( JP )
PERM( J ) = INDXQ( INDX( JP ) )
CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
110 CONTINUE
*
* The deflated eigenvalues and their corresponding vectors go back
* into the last N - K slots of D and Q respectively.
*
IF( K.LT.N ) THEN
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ),
$ LDQ )
END IF
*
RETURN
*
* End of ZLAED8
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/Makefile 0000644 0000000 0000000 00000000132 14061636515 015315 x ustar 00 30 mtime=1623670093.432103868
30 atime=1623670093.432103868
30 ctime=1623670093.432103868
elk-7.2.42/src/LAPACK/Makefile 0000644 0025044 0025044 00000005244 14061636515 017357 0 ustar 00dewhurst dewhurst 0000000 0000000
AR = ar
include ../../make.inc
#-------------------------------------------------------------------------------
# Suffix Rules
#-------------------------------------------------------------------------------
.SUFFIXES: .o .f
.f.o:
$(F77) $(F77_OPTS) -c $<
#-------------------------------------------------------------------------------
# File dependencies
#-------------------------------------------------------------------------------
SRC = \
dcombssq.f dgesv.f dgetrf2.f dgetrf.f dgetri.f dgetrs.f \
disnan.f dlabad.f dlacpy.f dladiv.f dlae2.f dlaebz.f \
dlaed0.f dlaed1.f dlaed2.f dlaed3.f dlaed4.f dlaed5.f \
dlaed6.f dlaed7.f dlaed8.f dlaed9.f dlaeda.f dlaev2.f \
dlagtf.f dlagts.f dlaisnan.f dlamch.f dlamrg.f dlanst.f \
dlansy.f dlapy2.f dlapy3.f dlarfb.f dlarf.f dlarfg.f \
dlarft.f dlarnv.f dlartg.f dlaruv.f dlas2.f dlascl.f \
dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f \
dlasq6.f dlasr.f dlasrt.f dlassq.f dlasv2.f dlaswp.f \
dlatrd.f dorg2l.f dorg2r.f dorgql.f dorgqr.f dorgtr.f \
dorm2l.f dorm2r.f dormql.f dormqr.f dormtr.f dpotrf2.f \
dpotrf.f dstebz.f dstedc.f dstein.f dsteqr.f dsterf.f \
dsyev.f dsyevx.f dsygs2.f dsygst.f dsygvx.f dsytd2.f \
dsytrd.f dtrti2.f dtrtri.f ieeeck.f iladlc.f iladlr.f \
ilaenv.f ilazlc.f ilazlr.f iparam2stage.f iparmq.f xerbla.f \
zbdsqr.f zgebak.f zgebal.f zgebd2.f zgebrd.f zgeev.f \
zgehd2.f zgehrd.f zgelq2.f zgelqf.f zgeqr2.f zgeqrf.f \
zgesvd.f zgesv.f zgetrf2.f zgetrf.f zgetri.f zgetrs.f \
zheevd.f zheev.f zheevx.f zhegs2.f zhegst.f zhegv.f \
zhegvx.f zhetd2.f zhetrd.f zhpevx.f zhpgst.f zhpgvx.f \
zhptrd.f zhseqr.f zlabrd.f zlacgv.f zlacpy.f zlacrm.f \
zladiv.f zlaed0.f zlaed7.f zlaed8.f zlahqr.f zlahr2.f \
zlange.f zlanhe.f zlanhp.f zlaqr0.f zlaqr1.f zlaqr2.f \
zlaqr3.f zlaqr4.f zlaqr5.f zlarfb.f zlarf.f zlarfg.f \
zlarft.f zlartg.f zlascl.f zlaset.f zlasr.f zlassq.f \
zlaswp.f zlatrd.f zlatrs.f zpotrf2.f zpotrf.f zpptrf.f \
zrot.f zstedc.f zstein.f zsteqr.f ztrevc3.f ztrexc.f \
ztrti2.f ztrtri.f zung2l.f zung2r.f zungbr.f zunghr.f \
zungl2.f zunglq.f zungql.f zungqr.f zungtr.f zunm2l.f \
zunm2r.f zunmbr.f zunmhr.f zunml2.f zunmlq.f zunmql.f \
zunmqr.f zunmtr.f zupgtr.f zupmtr.f
OBJ = $(SRC:.f=.o)
lapack: $(OBJ)
$(AR) -rc lapack.a $(OBJ)
clean:
rm -f *.o *.mod *~ *.a ifc* *.gcno gmon.out
ls:
ls -x --tabsize=0 --width=80 *.f
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed9.f 0000644 0000000 0000000 00000000132 14061636515 015166 x ustar 00 30 mtime=1623670093.434103867
30 atime=1623670093.434103867
30 ctime=1623670093.434103867
elk-7.2.42/src/LAPACK/dlaed9.f 0000644 0025044 0025044 00000020722 14061636515 017226 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED9 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 DLAED9 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
* S, LDS, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
* $ W( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED9 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 DLAED4 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
*> DLAED4. 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 DOUBLE PRECISION array, dimension (N)
*> D(I) contains the updated eigenvalues
*> for KSTART <= I <= KSTOP.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is DOUBLE PRECISION 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 DOUBLE PRECISION
*> The value of the parameter in the rank one update equation.
*> RHO >= 0 required.
*> \endverbatim
*>
*> \param[in] DLAMDA
*> \verbatim
*> DLAMDA is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAED9( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
$ W( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLAED4, 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( 'DLAED9', -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 ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = KSTART, KSTOP
CALL DLAED4( 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 DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( 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 = DNRM2( 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 DLAED9
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlamrg.f 0000644 0000000 0000000 00000000132 14061636515 015272 x ustar 00 30 mtime=1623670093.436103865
30 atime=1623670093.436103865
30 ctime=1623670093.436103865
elk-7.2.42/src/LAPACK/dlamrg.f 0000644 0025044 0025044 00000010713 14061636515 017331 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAMRG 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 DLAMRG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
*
* .. Scalar Arguments ..
* INTEGER DTRD1, DTRD2, N1, N2
* ..
* .. Array Arguments ..
* INTEGER INDEX( * )
* DOUBLE PRECISION A( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAMRG 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 DOUBLE PRECISION 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] DTRD1
*> \verbatim
*> DTRD1 is INTEGER
*> \endverbatim
*>
*> \param[in] DTRD2
*> \verbatim
*> DTRD2 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 (DTRDx = 1) or descending
*> (DTRDx = -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 DLAMRG( N1, N2, A, DTRD1, DTRD2, 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 DTRD1, DTRD2, N1, N2
* ..
* .. Array Arguments ..
INTEGER INDEX( * )
DOUBLE PRECISION A( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IND1, IND2, N1SV, N2SV
* ..
* .. Executable Statements ..
*
N1SV = N1
N2SV = N2
IF( DTRD1.GT.0 ) THEN
IND1 = 1
ELSE
IND1 = N1
END IF
IF( DTRD2.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 + DTRD1
N1SV = N1SV - 1
ELSE
INDEX( I ) = IND2
I = I + 1
IND2 = IND2 + DTRD2
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 + DTRD2
20 CONTINUE
ELSE
* N2SV .EQ. 0
DO 30 N2SV = 1, N1SV
INDEX( I ) = IND1
I = I + 1
IND1 = IND1 + DTRD1
30 CONTINUE
END IF
*
RETURN
*
* End of DLAMRG
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zunmhr.f 0000644 0000000 0000000 00000000132 14061636515 015347 x ustar 00 30 mtime=1623670093.438103863
30 atime=1623670093.437103864
30 ctime=1623670093.438103863
elk-7.2.42/src/LAPACK/zunmhr.f 0000644 0025044 0025044 00000020247 14061636515 017411 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZUNMHR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNMHR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
* LDC, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZUNMHR overwrites the general complex M-by-N matrix C with
*>
*> SIDE = 'L' SIDE = 'R'
*> TRANS = 'N': Q * C C * Q
*> TRANS = 'C': Q**H * C C * Q**H
*>
*> where Q is a complex unitary matrix of order nq, with nq = m if
*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
*> IHI-ILO elementary reflectors, as returned by ZGEHRD:
*>
*> Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**H from the Left;
*> = 'R': apply Q or Q**H from the Right.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'C': apply Q**H (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*> ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*> IHI is INTEGER
*>
*> ILO and IHI must have the same values as in the previous call
*> of ZGEHRD. Q is equal to the unit matrix except in the
*> submatrix Q(ilo+1:ihi,ilo+1:ihi).
*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
*> ILO = 1 and IHI = 0, if M = 0;
*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
*> ILO = 1 and IHI = 0, if N = 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX*16 array, dimension
*> (LDA,M) if SIDE = 'L'
*> (LDA,N) if SIDE = 'R'
*> The vectors which define the elementary reflectors, as
*> returned by ZGEHRD.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is COMPLEX*16 array, dimension
*> (M-1) if SIDE = 'L'
*> (N-1) if SIDE = 'R'
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by ZGEHRD.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX*16 array, dimension (LDC,N)
*> On entry, the M-by-N matrix C.
*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> If SIDE = 'L', LWORK >= max(1,N);
*> if SIDE = 'R', LWORK >= max(1,M).
*> For optimum performance LWORK >= N*NB if SIDE = 'L', and
*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*> blocksize.
*>
*> If LWORK = -1, then a workspace query is assumed; the routine
*> only calculates the optimal size of the WORK array, returns
*> this value as the first entry of the WORK array, and no error
*> message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, 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 SIDE, TRANS
INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL LEFT, LQUERY
INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILAENV
EXTERNAL LSAME, ILAENV
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNMQR
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
NH = IHI - ILO
LEFT = LSAME( SIDE, 'L' )
LQUERY = ( LWORK.EQ.-1 )
*
* NQ is the order of Q and NW is the minimum dimension of WORK
*
IF( LEFT ) THEN
NQ = M
NW = N
ELSE
NQ = N
NW = M
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
$ THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
INFO = -5
ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -11
ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
INFO = -13
END IF
*
IF( INFO.EQ.0 ) THEN
IF( LEFT ) THEN
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 )
ELSE
NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 )
END IF
LWKOPT = MAX( 1, NW )*NB
WORK( 1 ) = LWKOPT
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNMHR', -INFO )
RETURN
ELSE IF( LQUERY ) THEN
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( LEFT ) THEN
MI = NH
NI = N
I1 = ILO + 1
I2 = 1
ELSE
MI = M
NI = NH
I1 = 1
I2 = ILO + 1
END IF
*
CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
$ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
*
WORK( 1 ) = LWKOPT
RETURN
*
* End of ZUNMHR
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/ztrexc.f 0000644 0000000 0000000 00000000132 14061636515 015343 x ustar 00 30 mtime=1623670093.440103861
30 atime=1623670093.439103862
30 ctime=1623670093.440103861
elk-7.2.42/src/LAPACK/ztrexc.f 0000644 0025044 0025044 00000014563 14061636515 017411 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZTREXC
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTREXC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
*
* .. Scalar Arguments ..
* CHARACTER COMPQ
* INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
* COMPLEX*16 Q( LDQ, * ), T( LDT, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZTREXC reorders the Schur factorization of a complex matrix
*> A = Q*T*Q**H, so that the diagonal element of T with row index IFST
*> is moved to row ILST.
*>
*> The Schur form T is reordered by a unitary similarity transformation
*> Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
*> postmultplying it with Z.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMPQ
*> \verbatim
*> COMPQ is CHARACTER*1
*> = 'V': update the matrix Q of Schur vectors;
*> = 'N': do not update Q.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix T. N >= 0.
*> If N == 0 arguments ILST and IFST may be any value.
*> \endverbatim
*>
*> \param[in,out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,N)
*> On entry, the upper triangular matrix T.
*> On exit, the reordered upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of the array T. LDT >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is COMPLEX*16 array, dimension (LDQ,N)
*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
*> On exit, if COMPQ = 'V', Q has been postmultiplied by the
*> unitary transformation matrix Z which reorders T.
*> If COMPQ = 'N', Q is not referenced.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1, and if
*> COMPQ = 'V', LDQ >= max(1,N).
*> \endverbatim
*>
*> \param[in] IFST
*> \verbatim
*> IFST is INTEGER
*> \endverbatim
*>
*> \param[in] ILST
*> \verbatim
*> ILST is INTEGER
*>
*> Specify the reordering of the diagonal elements of T:
*> The element with row index IFST is moved to row ILST by a
*> sequence of transpositions between adjacent elements.
*> 1 <= IFST <= N; 1 <= ILST <= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
* =====================================================================
SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, 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 COMPQ
INTEGER IFST, ILST, INFO, LDQ, LDT, N
* ..
* .. Array Arguments ..
COMPLEX*16 Q( LDQ, * ), T( LDT, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL WANTQ
INTEGER K, M1, M2, M3
DOUBLE PRECISION CS
COMPLEX*16 SN, T11, T22, TEMP
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARTG, ZROT
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Decode and test the input parameters.
*
INFO = 0
WANTQ = LSAME( COMPQ, 'V' )
IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
INFO = -6
ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN
INFO = -7
ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZTREXC', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 .OR. IFST.EQ.ILST )
$ RETURN
*
IF( IFST.LT.ILST ) THEN
*
* Move the IFST-th diagonal element forward down the diagonal.
*
M1 = 0
M2 = -1
M3 = 1
ELSE
*
* Move the IFST-th diagonal element backward up the diagonal.
*
M1 = -1
M2 = 0
M3 = -1
END IF
*
DO 10 K = IFST + M1, ILST + M2, M3
*
* Interchange the k-th and (k+1)-th diagonal elements.
*
T11 = T( K, K )
T22 = T( K+1, K+1 )
*
* Determine the transformation to perform the interchange.
*
CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP )
*
* Apply transformation to the matrix T.
*
IF( K+2.LE.N )
$ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS,
$ SN )
CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS,
$ DCONJG( SN ) )
*
T( K, K ) = T22
T( K+1, K+1 ) = T11
*
IF( WANTQ ) THEN
*
* Accumulate transformation in the matrix Q.
*
CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS,
$ DCONJG( SN ) )
END IF
*
10 CONTINUE
*
RETURN
*
* End of ZTREXC
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr2.f 0000644 0000000 0000000 00000000131 14061636515 015236 x ustar 00 30 mtime=1623670093.442103859
29 atime=1623670093.44110386
30 ctime=1623670093.442103859
elk-7.2.42/src/LAPACK/zlaqr2.f 0000644 0025044 0025044 00000042236 14061636515 017303 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
* NV, WV, LDWV, WORK, LWORK )
*
* .. Scalar Arguments ..
* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
* $ LDZ, LWORK, N, ND, NH, NS, NV, NW
* LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLAQR2 is identical to ZLAQR3 except that it avoids
*> recursion by calling ZLAHQR instead of ZLAQR4.
*>
*> Aggressive early deflation:
*>
*> ZLAQR2 accepts as input an upper Hessenberg matrix
*> H and performs an unitary similarity transformation
*> designed to detect and deflate fully converged eigenvalues from
*> a trailing principal submatrix. On output H has been over-
*> written by a new Hessenberg matrix that is a perturbation of
*> an unitary similarity transformation of H. It is to be
*> hoped that the final version of H has many zero subdiagonal
*> entries.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTT
*> \verbatim
*> WANTT is LOGICAL
*> If .TRUE., then the Hessenberg matrix H is fully updated
*> so that the triangular Schur factor may be
*> computed (in cooperation with the calling subroutine).
*> If .FALSE., then only enough of H is updated to preserve
*> the eigenvalues.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> If .TRUE., then the unitary matrix Z is updated so
*> so that the unitary Schur factor may be computed
*> (in cooperation with the calling subroutine).
*> If .FALSE., then Z is not referenced.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix H and (if WANTZ is .TRUE.) the
*> order of the unitary matrix Z.
*> \endverbatim
*>
*> \param[in] KTOP
*> \verbatim
*> KTOP is INTEGER
*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
*> KBOT and KTOP together determine an isolated block
*> along the diagonal of the Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] KBOT
*> \verbatim
*> KBOT is INTEGER
*> It is assumed without a check that either
*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
*> determine an isolated block along the diagonal of the
*> Hessenberg matrix.
*> \endverbatim
*>
*> \param[in] NW
*> \verbatim
*> NW is INTEGER
*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1).
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> On input the initial N-by-N section of H stores the
*> Hessenberg matrix undergoing aggressive early deflation.
*> On output H has been transformed by a unitary
*> similarity transformation, perturbed, and the returned
*> to Hessenberg form that (it is to be hoped) has some
*> zero subdiagonal entries.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> Leading dimension of H just as declared in the calling
*> subroutine. N <= LDH
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*> ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*> IHIZ is INTEGER
*> Specify the rows of Z to which transformations must be
*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is COMPLEX*16 array, dimension (LDZ,N)
*> IF WANTZ is .TRUE., then on output, the unitary
*> similarity transformation mentioned above has been
*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
*> If WANTZ is .FALSE., then Z is unreferenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of Z just as declared in the
*> calling subroutine. 1 <= LDZ.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*> NS is INTEGER
*> The number of unconverged (ie approximate) eigenvalues
*> returned in SR and SI that may be used as shifts by the
*> calling subroutine.
*> \endverbatim
*>
*> \param[out] ND
*> \verbatim
*> ND is INTEGER
*> The number of converged eigenvalues uncovered by this
*> subroutine.
*> \endverbatim
*>
*> \param[out] SH
*> \verbatim
*> SH is COMPLEX*16 array, dimension (KBOT)
*> On output, approximate eigenvalues that may
*> be used for shifts are stored in SH(KBOT-ND-NS+1)
*> through SR(KBOT-ND). Converged eigenvalues are
*> stored in SH(KBOT-ND+1) through SH(KBOT).
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (LDV,NW)
*> An NW-by-NW work array.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*> LDV is INTEGER
*> The leading dimension of V just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[in] NH
*> \verbatim
*> NH is INTEGER
*> The number of columns of T. NH >= NW.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*> T is COMPLEX*16 array, dimension (LDT,NW)
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*> LDT is INTEGER
*> The leading dimension of T just as declared in the
*> calling subroutine. NW <= LDT
*> \endverbatim
*>
*> \param[in] NV
*> \verbatim
*> NV is INTEGER
*> The number of rows of work array WV available for
*> workspace. NV >= NW.
*> \endverbatim
*>
*> \param[out] WV
*> \verbatim
*> WV is COMPLEX*16 array, dimension (LDWV,NW)
*> \endverbatim
*>
*> \param[in] LDWV
*> \verbatim
*> LDWV is INTEGER
*> The leading dimension of W just as declared in the
*> calling subroutine. NW <= LDV
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is COMPLEX*16 array, dimension (LWORK)
*> On exit, WORK(1) is set to an estimate of the optimal value
*> of LWORK for the given values of N, NW, KTOP and KBOT.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the work array WORK. LWORK = 2*NW
*> suffices, but greater efficiency may result from larger
*> values of LWORK.
*>
*> If LWORK = -1, then a workspace query is assumed; ZLAQR2
*> only estimates the optimal workspace size for the given
*> values of N, NW, KTOP and KBOT. The estimate is returned
*> in WORK(1). No error message related to LWORK is issued
*> by XERBLA. Neither H nor Z are accessed.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
$ NV, WV, LDWV, WORK, LWORK )
*
* -- LAPACK auxiliary routine (version 3.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 IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
$ LDZ, LWORK, N, ND, NH, NS, NV, NW
LOGICAL WANTT, WANTZ
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
$ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ),
$ ONE = ( 1.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO, RONE
PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 BETA, CDUM, S, TAU
DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP
INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
$ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
$ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* ==== Estimate optimal workspace. ====
*
JW = MIN( NW, KBOT-KTOP+1 )
IF( JW.LE.2 ) THEN
LWKOPT = 1
ELSE
*
* ==== Workspace query call to ZGEHRD ====
*
CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
LWK1 = INT( WORK( 1 ) )
*
* ==== Workspace query call to ZUNMHR ====
*
CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV,
$ WORK, -1, INFO )
LWK2 = INT( WORK( 1 ) )
*
* ==== Optimal workspace ====
*
LWKOPT = JW + MAX( LWK1, LWK2 )
END IF
*
* ==== Quick return in case of workspace query. ====
*
IF( LWORK.EQ.-1 ) THEN
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
RETURN
END IF
*
* ==== Nothing to do ...
* ... for an empty active block ... ====
NS = 0
ND = 0
WORK( 1 ) = ONE
IF( KTOP.GT.KBOT )
$ RETURN
* ... nor for an empty deflation window. ====
IF( NW.LT.1 )
$ RETURN
*
* ==== Machine constants ====
*
SAFMIN = DLAMCH( 'SAFE MINIMUM' )
SAFMAX = RONE / SAFMIN
CALL DLABAD( SAFMIN, SAFMAX )
ULP = DLAMCH( 'PRECISION' )
SMLNUM = SAFMIN*( DBLE( N ) / ULP )
*
* ==== Setup deflation window ====
*
JW = MIN( NW, KBOT-KTOP+1 )
KWTOP = KBOT - JW + 1
IF( KWTOP.EQ.KTOP ) THEN
S = ZERO
ELSE
S = H( KWTOP, KWTOP-1 )
END IF
*
IF( KBOT.EQ.KWTOP ) THEN
*
* ==== 1-by-1 deflation window: not much to do ====
*
SH( KWTOP ) = H( KWTOP, KWTOP )
NS = 1
ND = 0
IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
$ KWTOP ) ) ) ) THEN
NS = 0
ND = 1
IF( KWTOP.GT.KTOP )
$ H( KWTOP, KWTOP-1 ) = ZERO
END IF
WORK( 1 ) = ONE
RETURN
END IF
*
* ==== Convert to spike-triangular form. (In case of a
* . rare QR failure, this routine continues to do
* . aggressive early deflation using that part of
* . the deflation window that converged using INFQR
* . here and there to keep track.) ====
*
CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
*
CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
$ JW, V, LDV, INFQR )
*
* ==== Deflation detection loop ====
*
NS = JW
ILST = INFQR + 1
DO 10 KNT = INFQR + 1, JW
*
* ==== Small spike tip deflation test ====
*
FOO = CABS1( T( NS, NS ) )
IF( FOO.EQ.RZERO )
$ FOO = CABS1( S )
IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
$ THEN
*
* ==== One more converged eigenvalue ====
*
NS = NS - 1
ELSE
*
* ==== One undeflatable eigenvalue. Move it up out of the
* . way. (ZTREXC can not fail in this case.) ====
*
IFST = NS
CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
ILST = ILST + 1
END IF
10 CONTINUE
*
* ==== Return to Hessenberg form ====
*
IF( NS.EQ.0 )
$ S = ZERO
*
IF( NS.LT.JW ) THEN
*
* ==== sorting the diagonal of T improves accuracy for
* . graded matrices. ====
*
DO 30 I = INFQR + 1, NS
IFST = I
DO 20 J = I + 1, NS
IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
$ IFST = J
20 CONTINUE
ILST = I
IF( IFST.NE.ILST )
$ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
30 CONTINUE
END IF
*
* ==== Restore shift/eigenvalue array from T ====
*
DO 40 I = INFQR + 1, JW
SH( KWTOP+I-1 ) = T( I, I )
40 CONTINUE
*
*
IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
*
* ==== Reflect spike back into lower triangle ====
*
CALL ZCOPY( NS, V, LDV, WORK, 1 )
DO 50 I = 1, NS
WORK( I ) = DCONJG( WORK( I ) )
50 CONTINUE
BETA = WORK( 1 )
CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
WORK( 1 ) = ONE
*
CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
*
CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
$ WORK( JW+1 ) )
CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
$ WORK( JW+1 ) )
*
CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
$ LWORK-JW, INFO )
END IF
*
* ==== Copy updated reduced window into place ====
*
IF( KWTOP.GT.1 )
$ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
$ LDH+1 )
*
* ==== Accumulate orthogonal matrix in order update
* . H and Z, if requested. ====
*
IF( NS.GT.1 .AND. S.NE.ZERO )
$ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV,
$ WORK( JW+1 ), LWORK-JW, INFO )
*
* ==== Update vertical slab in H ====
*
IF( WANTT ) THEN
LTOP = 1
ELSE
LTOP = KTOP
END IF
DO 60 KROW = LTOP, KWTOP - 1, NV
KLN = MIN( NV, KWTOP-KROW )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
$ LDH, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
60 CONTINUE
*
* ==== Update horizontal slab in H ====
*
IF( WANTT ) THEN
DO 70 KCOL = KBOT + 1, N, NH
KLN = MIN( NH, N-KCOL+1 )
CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
$ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
$ LDH )
70 CONTINUE
END IF
*
* ==== Update vertical slab in Z ====
*
IF( WANTZ ) THEN
DO 80 KROW = ILOZ, IHIZ, NV
KLN = MIN( NV, IHIZ-KROW+1 )
CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
$ LDZ, V, LDV, ZERO, WV, LDWV )
CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
$ LDZ )
80 CONTINUE
END IF
END IF
*
* ==== Return the number of deflations ... ====
*
ND = JW - NS
*
* ==== ... and the number of shifts. (Subtracting
* . INFQR from the spike length takes care
* . of the case of a rare QR failure while
* . calculating eigenvalues of the deflation
* . window.) ====
*
NS = NS - INFQR
*
* ==== Return optimal workspace. ====
*
WORK( 1 ) = DCMPLX( LWKOPT, 0 )
*
* ==== End of ZLAQR2 ====
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlaqr1.f 0000644 0000000 0000000 00000000132 14061636515 015236 x ustar 00 30 mtime=1623670093.443103858
30 atime=1623670093.443103858
30 ctime=1623670093.443103858
elk-7.2.42/src/LAPACK/zlaqr1.f 0000644 0025044 0025044 00000011522 14061636515 017274 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAQR1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
*
* .. Scalar Arguments ..
* COMPLEX*16 S1, S2
* INTEGER LDH, N
* ..
* .. Array Arguments ..
* COMPLEX*16 H( LDH, * ), V( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a
*> scalar multiple of the first column of the product
*>
*> (*) K = (H - s1*I)*(H - s2*I)
*>
*> scaling to avoid overflows and most underflows.
*>
*> This is useful for starting double implicit shift bulges
*> in the QR algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> Order of the matrix H. N must be either 2 or 3.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*> H is COMPLEX*16 array, dimension (LDH,N)
*> The 2-by-2 or 3-by-3 matrix H in (*).
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*> LDH is INTEGER
*> The leading dimension of H as declared in
*> the calling procedure. LDH >= N
*> \endverbatim
*>
*> \param[in] S1
*> \verbatim
*> S1 is COMPLEX*16
*> \endverbatim
*>
*> \param[in] S2
*> \verbatim
*> S2 is COMPLEX*16
*>
*> S1 and S2 are the shifts defining K in (*) above.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is COMPLEX*16 array, dimension (N)
*> A scalar multiple of the first column of the
*> matrix K in (*).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Contributors:
* ==================
*>
*> Karen Braman and Ralph Byers, Department of Mathematics,
*> University of Kansas, USA
*>
* =====================================================================
SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
*
* -- LAPACK auxiliary routine (version 3.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 ..
COMPLEX*16 S1, S2
INTEGER LDH, N
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), V( * )
* ..
*
* ================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0d0 )
* ..
* .. Local Scalars ..
COMPLEX*16 CDUM, H21S, H31S
DOUBLE PRECISION S
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.NE.2 .AND. N.NE.3 ) THEN
RETURN
END IF
*
IF( N.EQ.2 ) THEN
S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) )
IF( S.EQ.RZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )*
$ ( ( H( 1, 1 )-S2 ) / S )
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 )
END IF
ELSE
S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) +
$ CABS1( H( 3, 1 ) )
IF( S.EQ.ZERO ) THEN
V( 1 ) = ZERO
V( 2 ) = ZERO
V( 3 ) = ZERO
ELSE
H21S = H( 2, 1 ) / S
H31S = H( 3, 1 ) / S
V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) +
$ H( 1, 2 )*H21S + H( 1, 3 )*H31S
V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S
V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 )
END IF
END IF
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed3.f 0000644 0000000 0000000 00000000132 14061636515 015160 x ustar 00 30 mtime=1623670093.445103856
30 atime=1623670093.445103856
30 ctime=1623670093.445103856
elk-7.2.42/src/LAPACK/dlaed3.f 0000644 0025044 0025044 00000025300 14061636515 017215 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED3 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 DLAED3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
* CTOT, W, S, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDQ, N, N1
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER CTOT( * ), INDX( * )
* DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
* $ S( * ), W( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED3 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 DLAED4 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
*> DLAED4. 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 DOUBLE PRECISION array, dimension (N)
*> D(I) contains the updated eigenvalues for
*> 1 <= I <= K.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*> Q is DOUBLE PRECISION 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 DOUBLE PRECISION
*> The value of the parameter in the rank one update equation.
*> RHO >= 0 required.
*> \endverbatim
*>
*> \param[in,out] DLAMDA
*> \verbatim
*> DLAMDA is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAED2).
*> The rows of the eigenvectors found by DLAED4 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DLAED3( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER CTOT( * ), INDX( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
$ S( * ), W( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER I, II, IQ2, J, N12, N2, N23
DOUBLE PRECISION TEMP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3, DNRM2
EXTERNAL DLAMC3, DNRM2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, 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( 'DLAED3', -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 ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
10 CONTINUE
*
DO 20 J = 1, K
CALL DLAED4( 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 DCOPY( K, W, 1, S, 1 )
*
* Initialize W(I) = Q(I,I)
*
CALL DCOPY( 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 = DNRM2( 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 DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
IQ2 = N1*N12 + 1
IF( N23.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
$ ZERO, Q( N1+1, 1 ), LDQ )
ELSE
CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
END IF
*
CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
IF( N12.NE.0 ) THEN
CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
$ LDQ )
ELSE
CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
END IF
*
*
120 CONTINUE
RETURN
*
* End of DLAED3
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed8.f 0000644 0000000 0000000 00000000132 14061636515 015165 x ustar 00 30 mtime=1623670093.447103854
30 atime=1623670093.447103854
30 ctime=1623670093.447103854
elk-7.2.42/src/LAPACK/dlaed8.f 0000644 0025044 0025044 00000037262 14061636515 017234 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED8 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 DLAED8 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED8( 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
* DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
* $ INDXQ( * ), PERM( * )
* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
* $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED8 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION
*> 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
*> DLAED3.
*> \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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
*> A copy of the first K eigenvalues which will be used by
*> DLAED3 to form the secular equation.
*> \endverbatim
*>
*> \param[out] Q2
*> \verbatim
*> Q2 is DOUBLE PRECISION array, dimension (LDQ2,N)
*> If ICOMPQ = 0, Q2 is not referenced. Otherwise,
*> a copy of the first K eigenvectors which will be used by
*> DLAED7 in a matrix multiply (DGEMM) to update the new
*> eigenvectors.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of the array Q2. LDQ2 >= max(1,N).
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*> W is DOUBLE PRECISION array, dimension (N)
*> The first k values of the final deflation-altered z-vector and
*> will be passed to DLAED3.
*> \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 DOUBLE PRECISION 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 DLAED8( 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
DOUBLE PRECISION RHO
* ..
* .. Array Arguments ..
INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
$ INDXQ( * ), PERM( * )
DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
$ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, EIGHT = 8.0D0 )
* ..
* .. Local Scalars ..
*
INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
DOUBLE PRECISION C, EPS, S, T, TAU, TOL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL IDAMAX, DLAMCH, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, 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( 'DLAED8', -INFO )
RETURN
END IF
*
* Need to initialize GIVPTR to O here in case of quick exit
* to prevent an unspecified code behavior (usually sigfault)
* when IWORK array on entry to *stedc is not zeroed
* (or at least some IWORK entries which used in *laed7 for GIVPTR).
*
GIVPTR = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
N1 = CUTPNT
N2 = N - N1
N1P1 = N1 + 1
*
IF( RHO.LT.ZERO ) THEN
CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
END IF
*
* Normalize z so that norm(z) = 1
*
T = ONE / SQRT( TWO )
DO 10 J = 1, N
INDX( J ) = J
10 CONTINUE
CALL DSCAL( N, T, Z, 1 )
RHO = ABS( TWO*RHO )
*
* Sort the eigenvalues into increasing order
*
DO 20 I = CUTPNT + 1, N
INDXQ( I ) = INDXQ( I ) + CUTPNT
20 CONTINUE
DO 30 I = 1, N
DLAMDA( I ) = D( INDXQ( I ) )
W( I ) = Z( INDXQ( I ) )
30 CONTINUE
I = 1
J = CUTPNT + 1
CALL DLAMRG( 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 = IDAMAX( N, Z, 1 )
JMAX = IDAMAX( N, D, 1 )
EPS = DLAMCH( 'Epsilon' )
TOL = EIGHT*EPS*ABS( D( JMAX ) )
*
* If the rank-1 modifier is small enough, no more needs to be done
* except to reorganize Q so that its columns correspond with the
* elements in D.
*
IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
K = 0
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 DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
60 CONTINUE
CALL DLACPY( '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 = DLAPY2( C, S )
T = D( J ) - D( JLAM )
C = C / TAU
S = -S / TAU
IF( ABS( T*C*S ).LE.TOL ) THEN
*
* Deflation is possible.
*
Z( J ) = TAU
Z( JLAM ) = ZERO
*
* Record the appropriate Givens rotation
*
GIVPTR = GIVPTR + 1
GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
GIVNUM( 1, GIVPTR ) = C
GIVNUM( 2, GIVPTR ) = S
IF( ICOMPQ.EQ.1 ) THEN
CALL DROT( 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 DCOPY( 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 DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
ELSE
CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
$ Q( 1, K+1 ), LDQ )
END IF
END IF
*
RETURN
*
* End of DLAED8
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed4.f 0000644 0000000 0000000 00000000132 14061636515 015161 x ustar 00 30 mtime=1623670093.449103853
30 atime=1623670093.449103853
30 ctime=1623670093.449103853
elk-7.2.42/src/LAPACK/dlaed4.f 0000644 0025044 0025044 00000064631 14061636515 017230 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED4 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 DLAED4 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
*
* .. Scalar Arguments ..
* INTEGER I, INFO, N
* DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
*> The components of the updating vector.
*> \endverbatim
*>
*> \param[out] DELTA
*> \verbatim
*> DELTA is DOUBLE PRECISION 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 DLAED5
*> for detail. The vector DELTA contains the information necessary
*> to construct the eigenvectors by DLAED3 and DLAED9.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> The scalar in the symmetric updating formula.
*> \endverbatim
*>
*> \param[out] DLAM
*> \verbatim
*> DLAM is DOUBLE PRECISION
*> 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 DLAED4( 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
DOUBLE PRECISION DLAM, RHO
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
$ TEN = 10.0D0 )
* ..
* .. Local Scalars ..
LOGICAL ORGATI, SWTCH, SWTCH3
INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
$ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
$ RHOINV, TAU, TEMP, TEMP1, W
* ..
* .. Local Arrays ..
DOUBLE PRECISION ZZ( 3 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DLAED5, DLAED6
* ..
* .. 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 DLAED5( I, D, Z, DELTA, RHO, DLAM )
RETURN
END IF
*
* Compute machine epsilon
*
EPS = DLAMCH( '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 DLAED6( 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 DLAED6( 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 DLAED4
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/iladlc.f 0000644 0000000 0000000 00000000130 14061636515 015252 x ustar 00 29 mtime=1623670093.45210385
30 atime=1623670093.451103851
29 ctime=1623670093.45210385
elk-7.2.42/src/LAPACK/iladlc.f 0000644 0025044 0025044 00000005642 14061636515 017320 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ILADLC scans a matrix for its last non-zero column.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLC 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 DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILADLC( M, N, 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILADLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILADLC = N, 1, -1
DO I = 1, M
IF( A(I, ILADLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/iladlr.f 0000644 0000000 0000000 00000000132 14061636515 015273 x ustar 00 30 mtime=1623670093.453103849
30 atime=1623670093.453103849
30 ctime=1623670093.453103849
elk-7.2.42/src/LAPACK/iladlr.f 0000644 0025044 0025044 00000005725 14061636515 017341 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ILADLR scans a matrix for its last non-zero row.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLR 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 DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
* =====================================================================
INTEGER FUNCTION ILADLR( M, N, 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 ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILADLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILADLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILADLR = MAX( ILADLR, I )
END DO
END IF
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq4.f 0000644 0000000 0000000 00000000132 14061636515 015214 x ustar 00 30 mtime=1623670093.455103847
30 atime=1623670093.455103847
30 ctime=1623670093.455103847
elk-7.2.42/src/LAPACK/dlasq4.f 0000644 0025044 0025044 00000026634 14061636515 017264 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ4 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
* DN1, DN2, TAU, TTYPE, G )
*
* .. Scalar Arguments ..
* INTEGER I0, N0, N0IN, PP, TTYPE
* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ4 computes an approximation TAU to the smallest eigenvalue
*> using values of d from the previous transform.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] I0
*> \verbatim
*> I0 is INTEGER
*> First index.
*> \endverbatim
*>
*> \param[in] N0
*> \verbatim
*> N0 is INTEGER
*> Last index.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( 4*N0 )
*> Z holds the qd array.
*> \endverbatim
*>
*> \param[in] PP
*> \verbatim
*> PP is INTEGER
*> PP=0 for ping, PP=1 for pong.
*> \endverbatim
*>
*> \param[in] N0IN
*> \verbatim
*> N0IN is INTEGER
*> The value of N0 at start of EIGTEST.
*> \endverbatim
*>
*> \param[in] DMIN
*> \verbatim
*> DMIN is DOUBLE PRECISION
*> Minimum value of d.
*> \endverbatim
*>
*> \param[in] DMIN1
*> \verbatim
*> DMIN1 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ).
*> \endverbatim
*>
*> \param[in] DMIN2
*> \verbatim
*> DMIN2 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*> \endverbatim
*>
*> \param[in] DN
*> \verbatim
*> DN is DOUBLE PRECISION
*> d(N)
*> \endverbatim
*>
*> \param[in] DN1
*> \verbatim
*> DN1 is DOUBLE PRECISION
*> d(N-1)
*> \endverbatim
*>
*> \param[in] DN2
*> \verbatim
*> DN2 is DOUBLE PRECISION
*> d(N-2)
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> This is the shift.
*> \endverbatim
*>
*> \param[out] TTYPE
*> \verbatim
*> TTYPE is INTEGER
*> Shift type.
*> \endverbatim
*>
*> \param[in,out] G
*> \verbatim
*> G is DOUBLE PRECISION
*> G is passed as an argument in order to save its value between
*> calls to DLASQ4.
*> \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 Further Details:
* =====================
*>
*> \verbatim
*>
*> CNST1 = 9/16
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE, G )
*
* -- 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 2016
*
* .. Scalar Arguments ..
INTEGER I0, N0, N0IN, PP, TTYPE
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION CNST1, CNST2, CNST3
PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
$ CNST3 = 1.050D0 )
DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
$ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
$ TWO = 2.0D0, HUNDRD = 100.0D0 )
* ..
* .. Local Scalars ..
INTEGER I4, NN, NP
DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
* A negative DMIN forces the shift to take that absolute value
* TTYPE records the type of shift.
*
IF( DMIN.LE.ZERO ) THEN
TAU = -DMIN
TTYPE = -1
RETURN
END IF
*
NN = 4*N0 + PP
IF( N0IN.EQ.N0 ) THEN
*
* No eigenvalues deflated.
*
IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
*
B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
A2 = Z( NN-7 ) + Z( NN-5 )
*
* Cases 2 and 3.
*
IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
GAP2 = DMIN2 - A2 - DMIN2*QURTR
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
GAP1 = A2 - DN - ( B2 / GAP2 )*B2
ELSE
GAP1 = A2 - DN - ( B1+B2 )
END IF
IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
TTYPE = -2
ELSE
S = ZERO
IF( DN.GT.B1 )
$ S = DN - B1
IF( A2.GT.( B1+B2 ) )
$ S = MIN( S, A2-( B1+B2 ) )
S = MAX( S, THIRD*DMIN )
TTYPE = -3
END IF
ELSE
*
* Case 4.
*
TTYPE = -4
S = QURTR*DMIN
IF( DMIN.EQ.DN ) THEN
GAM = DN
A2 = ZERO
IF( Z( NN-5 ) .GT. Z( NN-7 ) )
$ RETURN
B2 = Z( NN-5 ) / Z( NN-7 )
NP = NN - 9
ELSE
NP = NN - 2*PP
GAM = DN1
IF( Z( NP-4 ) .GT. Z( NP-2 ) )
$ RETURN
A2 = Z( NP-4 ) / Z( NP-2 )
IF( Z( NN-9 ) .GT. Z( NN-11 ) )
$ RETURN
B2 = Z( NN-9 ) / Z( NN-11 )
NP = NN - 13
END IF
*
* Approximate contribution to norm squared from I < NN-1.
*
A2 = A2 + B2
DO 10 I4 = NP, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 20
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 20
10 CONTINUE
20 CONTINUE
A2 = CNST3*A2
*
* Rayleigh quotient residual bound.
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
END IF
ELSE IF( DMIN.EQ.DN2 ) THEN
*
* Case 5.
*
TTYPE = -5
S = QURTR*DMIN
*
* Compute contribution to norm squared from I > NN-2.
*
NP = NN - 2*PP
B1 = Z( NP-2 )
B2 = Z( NP-6 )
GAM = DN2
IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
$ RETURN
A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
*
* Approximate contribution to norm squared from I < NN-2.
*
IF( N0-I0.GT.2 ) THEN
B2 = Z( NN-13 ) / Z( NN-15 )
A2 = A2 + B2
DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
IF( B2.EQ.ZERO )
$ GO TO 40
B1 = B2
IF( Z( I4 ) .GT. Z( I4-2 ) )
$ RETURN
B2 = B2*( Z( I4 ) / Z( I4-2 ) )
A2 = A2 + B2
IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
$ GO TO 40
30 CONTINUE
40 CONTINUE
A2 = CNST3*A2
END IF
*
IF( A2.LT.CNST1 )
$ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
ELSE
*
* Case 6, no information to guide us.
*
IF( TTYPE.EQ.-6 ) THEN
G = G + THIRD*( ONE-G )
ELSE IF( TTYPE.EQ.-18 ) THEN
G = QURTR*THIRD
ELSE
G = QURTR
END IF
S = G*DMIN
TTYPE = -6
END IF
*
ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
*
* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
*
IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
*
* Cases 7 and 8.
*
TTYPE = -7
S = THIRD*DMIN1
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 60
DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
A2 = B1
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
$ GO TO 60
50 CONTINUE
60 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN1 / ( ONE+B2**2 )
GAP2 = HALF*DMIN2 - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
TTYPE = -8
END IF
ELSE
*
* Case 9.
*
S = QURTR*DMIN1
IF( DMIN1.EQ.DN1 )
$ S = HALF*DMIN1
TTYPE = -9
END IF
*
ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
*
* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
*
* Cases 10 and 11.
*
IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
TTYPE = -10
S = THIRD*DMIN2
IF( Z( NN-5 ).GT.Z( NN-7 ) )
$ RETURN
B1 = Z( NN-5 ) / Z( NN-7 )
B2 = B1
IF( B2.EQ.ZERO )
$ GO TO 80
DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
IF( Z( I4 ).GT.Z( I4-2 ) )
$ RETURN
B1 = B1*( Z( I4 ) / Z( I4-2 ) )
B2 = B2 + B1
IF( HUNDRD*B1.LT.B2 )
$ GO TO 80
70 CONTINUE
80 CONTINUE
B2 = SQRT( CNST3*B2 )
A2 = DMIN2 / ( ONE+B2**2 )
GAP2 = Z( NN-7 ) + Z( NN-9 ) -
$ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
ELSE
S = MAX( S, A2*( ONE-CNST2*B2 ) )
END IF
ELSE
S = QURTR*DMIN2
TTYPE = -11
END IF
ELSE IF( N0IN.GT.( N0+2 ) ) THEN
*
* Case 12, more than two eigenvalues deflated. No information.
*
S = ZERO
TTYPE = -12
END IF
*
TAU = S
RETURN
*
* End of DLASQ4
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq5.f 0000644 0000000 0000000 00000000132 14061636515 015215 x ustar 00 30 mtime=1623670093.457103845
30 atime=1623670093.457103845
30 ctime=1623670093.457103845
elk-7.2.42/src/LAPACK/dlasq5.f 0000644 0025044 0025044 00000026255 14061636515 017264 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ5 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN,
* DNM1, DNM2, IEEE, EPS )
*
* .. Scalar Arguments ..
* LOGICAL IEEE
* INTEGER I0, N0, PP
* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ5 computes one dqds transform in ping-pong form, one
*> version for IEEE machines another for non IEEE machines.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] I0
*> \verbatim
*> I0 is INTEGER
*> First index.
*> \endverbatim
*>
*> \param[in] N0
*> \verbatim
*> N0 is INTEGER
*> Last index.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( 4*N )
*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
*> an extra argument.
*> \endverbatim
*>
*> \param[in] PP
*> \verbatim
*> PP is INTEGER
*> PP=0 for ping, PP=1 for pong.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> This is the shift.
*> \endverbatim
*>
*> \param[in] SIGMA
*> \verbatim
*> SIGMA is DOUBLE PRECISION
*> This is the accumulated shift up to this step.
*> \endverbatim
*>
*> \param[out] DMIN
*> \verbatim
*> DMIN is DOUBLE PRECISION
*> Minimum value of d.
*> \endverbatim
*>
*> \param[out] DMIN1
*> \verbatim
*> DMIN1 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ).
*> \endverbatim
*>
*> \param[out] DMIN2
*> \verbatim
*> DMIN2 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*> \endverbatim
*>
*> \param[out] DN
*> \verbatim
*> DN is DOUBLE PRECISION
*> d(N0), the last value of d.
*> \endverbatim
*>
*> \param[out] DNM1
*> \verbatim
*> DNM1 is DOUBLE PRECISION
*> d(N0-1).
*> \endverbatim
*>
*> \param[out] DNM2
*> \verbatim
*> DNM2 is DOUBLE PRECISION
*> d(N0-2).
*> \endverbatim
*>
*> \param[in] IEEE
*> \verbatim
*> IEEE is LOGICAL
*> Flag for IEEE or non IEEE arithmetic.
*> \endverbatim
*>
*> \param[in] EPS
*> \verbatim
*> EPS is DOUBLE PRECISION
*> This is the value of epsilon used.
*> \endverbatim
*>
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup auxOTHERcomputational
*
* =====================================================================
SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2,
$ DN, DNM1, DNM2, IEEE, EPS )
*
* -- 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 ..
LOGICAL IEEE
INTEGER I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU,
$ SIGMA, EPS
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO, HALF
PARAMETER ( ZERO = 0.0D0, HALF = 0.5 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, TEMP, DTHRESH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
DTHRESH = EPS*(SIGMA+TAU)
IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO
IF( TAU.NE.ZERO ) THEN
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
*
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 30 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
30 CONTINUE
ELSE
DO 40 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
40 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
ELSE
* This is the version that sets d's to zero if they are small enough
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 ) - TAU
DMIN = D
DMIN1 = -Z( J4 )
IF( IEEE ) THEN
*
* Code for IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 50 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
TEMP = Z( J4+1 ) / Z( J4-2 )
D = D*TEMP - TAU
IF( D.LT.DTHRESH ) D = ZERO
DMIN = MIN( DMIN, D )
Z( J4 ) = Z( J4-1 )*TEMP
EMIN = MIN( Z( J4 ), EMIN )
50 CONTINUE
ELSE
DO 60 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
TEMP = Z( J4+2 ) / Z( J4-3 )
D = D*TEMP - TAU
IF( D.LT.DTHRESH ) D = ZERO
DMIN = MIN( DMIN, D )
Z( J4-1 ) = Z( J4 )*TEMP
EMIN = MIN( Z( J4-1 ), EMIN )
60 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
DMIN = MIN( DMIN, DN )
*
ELSE
*
* Code for non IEEE arithmetic.
*
IF( PP.EQ.0 ) THEN
DO 70 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
END IF
IF( D.LT.DTHRESH) D = ZERO
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
70 CONTINUE
ELSE
DO 80 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( D.LT.ZERO ) THEN
RETURN
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
END IF
IF( D.LT.DTHRESH) D = ZERO
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
80 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( DNM2.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( DNM1.LT.ZERO ) THEN
RETURN
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
END IF
DMIN = MIN( DMIN, DN )
*
END IF
END IF
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ5
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlasq6.f 0000644 0000000 0000000 00000000132 14061636515 015216 x ustar 00 30 mtime=1623670093.459103843
30 atime=1623670093.459103843
30 ctime=1623670093.459103843
elk-7.2.42/src/LAPACK/dlasq6.f 0000644 0025044 0025044 00000015214 14061636515 017256 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASQ6 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
* DNM1, DNM2 )
*
* .. Scalar Arguments ..
* INTEGER I0, N0, PP
* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
* DOUBLE PRECISION Z( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASQ6 computes one dqd (shift equal to zero) transform in
*> ping-pong form, with protection against underflow and overflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] I0
*> \verbatim
*> I0 is INTEGER
*> First index.
*> \endverbatim
*>
*> \param[in] N0
*> \verbatim
*> N0 is INTEGER
*> Last index.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension ( 4*N )
*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
*> an extra argument.
*> \endverbatim
*>
*> \param[in] PP
*> \verbatim
*> PP is INTEGER
*> PP=0 for ping, PP=1 for pong.
*> \endverbatim
*>
*> \param[out] DMIN
*> \verbatim
*> DMIN is DOUBLE PRECISION
*> Minimum value of d.
*> \endverbatim
*>
*> \param[out] DMIN1
*> \verbatim
*> DMIN1 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ).
*> \endverbatim
*>
*> \param[out] DMIN2
*> \verbatim
*> DMIN2 is DOUBLE PRECISION
*> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
*> \endverbatim
*>
*> \param[out] DN
*> \verbatim
*> DN is DOUBLE PRECISION
*> d(N0), the last value of d.
*> \endverbatim
*>
*> \param[out] DNM1
*> \verbatim
*> DNM1 is DOUBLE PRECISION
*> d(N0-1).
*> \endverbatim
*>
*> \param[out] DNM2
*> \verbatim
*> DNM2 is DOUBLE PRECISION
*> d(N0-2).
*> \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 DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
* -- 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 I0, N0, PP
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
* ..
* .. Array Arguments ..
DOUBLE PRECISION Z( * )
* ..
*
* =====================================================================
*
* .. Parameter ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
INTEGER J4, J4P2
DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
* ..
* .. External Function ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( ( N0-I0-1 ).LE.0 )
$ RETURN
*
SAFMIN = DLAMCH( 'Safe minimum' )
J4 = 4*I0 + PP - 3
EMIN = Z( J4+4 )
D = Z( J4 )
DMIN = D
*
IF( PP.EQ.0 ) THEN
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-2 ) = D + Z( J4-1 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
D = Z( J4+1 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
TEMP = Z( J4+1 ) / Z( J4-2 )
Z( J4 ) = Z( J4-1 )*TEMP
D = D*TEMP
ELSE
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
D = Z( J4+1 )*( D / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4 ) )
10 CONTINUE
ELSE
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
Z( J4-3 ) = D + Z( J4 )
IF( Z( J4-3 ).EQ.ZERO ) THEN
Z( J4-1 ) = ZERO
D = Z( J4+2 )
DMIN = D
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
TEMP = Z( J4+2 ) / Z( J4-3 )
Z( J4-1 ) = Z( J4 )*TEMP
D = D*TEMP
ELSE
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
D = Z( J4+2 )*( D / Z( J4-3 ) )
END IF
DMIN = MIN( DMIN, D )
EMIN = MIN( EMIN, Z( J4-1 ) )
20 CONTINUE
END IF
*
* Unroll last two steps.
*
DNM2 = D
DMIN2 = DMIN
J4 = 4*( N0-2 ) - PP
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM2 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DNM1 = Z( J4P2+2 )
DMIN = DNM1
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DNM1 = DNM2*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DNM1 )
*
DMIN1 = DMIN
J4 = J4 + 4
J4P2 = J4 + 2*PP - 1
Z( J4-2 ) = DNM1 + Z( J4P2 )
IF( Z( J4-2 ).EQ.ZERO ) THEN
Z( J4 ) = ZERO
DN = Z( J4P2+2 )
DMIN = DN
EMIN = ZERO
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
TEMP = Z( J4P2+2 ) / Z( J4-2 )
Z( J4 ) = Z( J4P2 )*TEMP
DN = DNM1*TEMP
ELSE
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
END IF
DMIN = MIN( DMIN, DN )
*
Z( J4+2 ) = DN
Z( 4*N0-PP ) = EMIN
RETURN
*
* End of DLASQ6
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zlartg.f 0000644 0000000 0000000 00000000132 14061636515 015327 x ustar 00 30 mtime=1623670093.461103841
30 atime=1623670093.461103841
30 ctime=1623670093.461103841
elk-7.2.42/src/LAPACK/zlartg.f 0000644 0025044 0025044 00000016322 14061636515 017370 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARTG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CS
* COMPLEX*16 F, G, R, SN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZLARTG generates a plane rotation so that
*>
*> [ CS SN ] [ F ] [ R ]
*> [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.
*> [ -SN CS ] [ G ] [ 0 ]
*>
*> This is a faster version of the BLAS1 routine ZROTG, except for
*> the following differences:
*> F and G are unchanged on return.
*> If G=0, then CS=1 and SN=0.
*> If F=0, then CS=0 and SN is chosen so that R is real.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is COMPLEX*16
*> The first component of vector to be rotated.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is COMPLEX*16
*> The second component of vector to be rotated.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*> CS is DOUBLE PRECISION
*> The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*> SN is COMPLEX*16
*> The sine of the rotation.
*> \endverbatim
*>
*> \param[out] R
*> \verbatim
*> R is COMPLEX*16
*> The nonzero component of the rotated vector.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
*>
*> This version has a few statements commented out for thread safety
*> (machine parameters are computed on each entry). 10 feb 03, SJH.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.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 ..
DOUBLE PRECISION CS
COMPLEX*16 F, G, R, SN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION TWO, ONE, ZERO
PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 CZERO
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
* LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
$ SAFMN2, SAFMX2, SCALE
COMPLEX*16 FF, FS, GS
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
LOGICAL DISNAN
EXTERNAL DLAMCH, DLAPY2, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
$ MAX, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION ABS1, ABSSQ
* ..
* .. Statement Function definitions ..
ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
SCALE = MAX( ABS1( F ), ABS1( G ) )
FS = F
GS = G
COUNT = 0
IF( SCALE.GE.SAFMX2 ) THEN
10 CONTINUE
COUNT = COUNT + 1
FS = FS*SAFMN2
GS = GS*SAFMN2
SCALE = SCALE*SAFMN2
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
ELSE IF( SCALE.LE.SAFMN2 ) THEN
IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
CS = ONE
SN = CZERO
R = F
RETURN
END IF
20 CONTINUE
COUNT = COUNT - 1
FS = FS*SAFMX2
GS = GS*SAFMX2
SCALE = SCALE*SAFMX2
IF( SCALE.LE.SAFMN2 )
$ GO TO 20
END IF
F2 = ABSSQ( FS )
G2 = ABSSQ( GS )
IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
*
* This is a rare case: F is very small.
*
IF( F.EQ.CZERO ) THEN
CS = ZERO
R = DLAPY2( DBLE( G ), DIMAG( G ) )
* Do complex/real division explicitly with two real divisions
D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
RETURN
END IF
F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
* G2 and G2S are accurate
* G2 is at least SAFMIN, and G2S is at least SAFMN2
G2S = SQRT( G2 )
* Error in CS from underflow in F2S is at most
* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
* and so CS .lt. sqrt(SAFMIN)
* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
CS = F2S / G2S
* Make sure abs(FF) = 1
* Do complex/real division explicitly with 2 real divisions
IF( ABS1( F ).GT.ONE ) THEN
D = DLAPY2( DBLE( F ), DIMAG( F ) )
FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
ELSE
DR = SAFMX2*DBLE( F )
DI = SAFMX2*DIMAG( F )
D = DLAPY2( DR, DI )
FF = DCMPLX( DR / D, DI / D )
END IF
SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
R = CS*F + SN*G
ELSE
*
* This is the most common case.
* Neither F2 nor F2/G2 are less than SAFMIN
* F2S cannot overflow, and it is accurate
*
F2S = SQRT( ONE+G2 / F2 )
* Do the F2S(real)*FS(complex) multiply with two real multiplies
R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
CS = ONE / F2S
D = F2 + G2
* Do complex/real division explicitly with two real divisions
SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
SN = SN*DCONJG( GS )
IF( COUNT.NE.0 ) THEN
IF( COUNT.GT.0 ) THEN
DO 30 I = 1, COUNT
R = R*SAFMX2
30 CONTINUE
ELSE
DO 40 I = 1, -COUNT
R = R*SAFMN2
40 CONTINUE
END IF
END IF
END IF
RETURN
*
* End of ZLARTG
*
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/zrot.f 0000644 0000000 0000000 00000000127 14061636515 015026 x ustar 00 29 mtime=1623670093.46310384
29 atime=1623670093.46310384
29 ctime=1623670093.46310384
elk-7.2.42/src/LAPACK/zrot.f 0000644 0025044 0025044 00000010134 14061636515 017056 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZROT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* .. Scalar Arguments ..
* INTEGER INCX, INCY, N
* DOUBLE PRECISION C
* COMPLEX*16 S
* ..
* .. Array Arguments ..
* COMPLEX*16 CX( * ), CY( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ZROT applies a plane rotation, where the cos (C) is real and the
*> sin (S) is complex, and the vectors CX and CY are complex.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of elements in the vectors CX and CY.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX*16 array, dimension (N)
*> On input, the vector X.
*> On output, CX is overwritten with C*X + S*Y.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*> CY is COMPLEX*16 array, dimension (N)
*> On input, the vector Y.
*> On output, CY is overwritten with -CONJG(S)*X + C*Y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> The increment between successive values of CY. INCX <> 0.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is COMPLEX*16
*> C and S define a rotation
*> [ C S ]
*> [ -conjg(S) C ]
*> where C*C + S*CONJG(S) = 1.0.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERauxiliary
*
* =====================================================================
SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
* -- 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 ..
INTEGER INCX, INCY, N
DOUBLE PRECISION C
COMPLEX*16 S
* ..
* .. Array Arguments ..
COMPLEX*16 CX( * ), CY( * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, IX, IY
COMPLEX*16 STEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC DCONJG
* ..
* .. Executable Statements ..
*
IF( N.LE.0 )
$ RETURN
IF( INCX.EQ.1 .AND. INCY.EQ.1 )
$ GO TO 20
*
* Code for unequal increments or equal increments not equal to 1
*
IX = 1
IY = 1
IF( INCX.LT.0 )
$ IX = ( -N+1 )*INCX + 1
IF( INCY.LT.0 )
$ IY = ( -N+1 )*INCY + 1
DO 10 I = 1, N
STEMP = C*CX( IX ) + S*CY( IY )
CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
CX( IX ) = STEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
*
* Code for both increments equal to 1
*
20 CONTINUE
DO 30 I = 1, N
STEMP = C*CX( I ) + S*CY( I )
CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
CX( I ) = STEMP
30 CONTINUE
RETURN
END
elk-7.2.42/src/LAPACK/PaxHeaders.21776/dlaed6.f 0000644 0000000 0000000 00000000132 14061636515 015163 x ustar 00 30 mtime=1623670093.465103838
30 atime=1623670093.464103839
30 ctime=1623670093.465103838
elk-7.2.42/src/LAPACK/dlaed6.f 0000644 0025044 0025044 00000026553 14061636515 017233 0 ustar 00dewhurst dewhurst 0000000 0000000 *> \brief \b DLAED6 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 DLAED6 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* .. Scalar Arguments ..
* LOGICAL ORGATI
* INTEGER INFO, KNITER
* DOUBLE PRECISION FINIT, RHO, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION D( 3 ), Z( 3 )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAED6 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 DLAED4 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 DLAED4 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
*> DLAED4 for further details.
*> \endverbatim
*>
*> \param[in] RHO
*> \verbatim
*> RHO is DOUBLE PRECISION
*> Refer to the equation f(x) above.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (3)
*> D satisfies d(1) < d(2) < d(3).
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (3)
*> Each of the elements in z must be positive.
*> \endverbatim
*>
*> \param[in] FINIT
*> \verbatim
*> FINIT is DOUBLE PRECISION
*> 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 DOUBLE PRECISION
*> 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 DLAED6( 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
DOUBLE PRECISION FINIT, RHO, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( 3 ), Z( 3 )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXIT
PARAMETER ( MAXIT = 40 )
DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Local Arrays ..
DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
* ..
* .. Local Scalars ..
LOGICAL SCALE
INTEGER I, ITER, NITER
DOUBLE PRECISION 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 = DLAMCH( 'Epsilon' )
BASE = DLAMCH( 'Base' )
SMALL1 = BASE**( INT( LOG( DLAMCH( '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 DLAED6
*
END
elk-7.2.42/src/PaxHeaders.21776/fftlib 0000644 0000000 0000000 00000000132 14061636515 014113 x ustar 00 30 mtime=1623670093.474103829
30 atime=1623670093.471103832
30 ctime=1623670093.474103829
elk-7.2.42/src/fftlib/ 0000755 0025044 0025044 00000000000 14061636515 016225 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/fftlib/PaxHeaders.21776/Makefile 0000644 0000000 0000000 00000000127 14061636515 015634 x ustar 00 29 mtime=1623670093.47310383
29 atime=1623670093.47310383
29 ctime=1623670093.47310383
elk-7.2.42/src/fftlib/Makefile 0000644 0025044 0025044 00000001075 14061636515 017670 0 ustar 00dewhurst dewhurst 0000000 0000000
AR = ar
include ../../make.inc
#-------------------------------------------------------------------------------
# Suffix Rules
#-------------------------------------------------------------------------------
.SUFFIXES: .o .f90
.f90.o:
$(F90) $(F90_OPTS) -c $<
#-------------------------------------------------------------------------------
# File dependencies
#-------------------------------------------------------------------------------
SRC = cfftnd.f90
OBJ = $(SRC:.f90=.o)
fftlib: $(OBJ)
$(AR) -rc fftlib.a $(OBJ)
clean:
rm -f *.o *.mod *~ *.a ifc* *.gcno
elk-7.2.42/src/fftlib/PaxHeaders.21776/cfftnd.f90 0000644 0000000 0000000 00000000132 14061636515 015754 x ustar 00 30 mtime=1623670093.475103829
30 atime=1623670093.474103829
30 ctime=1623670093.475103829
elk-7.2.42/src/fftlib/cfftnd.f90 0000644 0025044 0025044 00000164174 14061636515 020026 0 ustar 00dewhurst dewhurst 0000000 0000000 module fftpack5
integer, parameter :: prec=kind(1.d0)
end module
subroutine cfftnd(nd,n,sgn,c)
!
! DESCRIPTION:
! In-place fast Fourier transform for complex arrays in $n_d$ dimensions. The
! forward transform is scaled by one over the size of the array. Uses a
! modified version of the FFTPACK5 library.
!
! INPUT/OUTPUT PARAMETERS:
! nd : number of dimensions (in,integer)
! n : mesh size (in,integer(nd))
! sgn : FFT direction, -1: forward, 1: backward (in,integer)
! c : array to transform (inout,complex(n(1)*n(2)*...*n(nd)))
!
! Copyright (C) 2005 J. K. Dewhurst
! Distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!
use fftpack5
implicit none
! arguments
integer, intent(in) :: nd
integer, intent(in) :: n(nd)
integer, intent(in) :: sgn
complex(prec), intent(inout) :: c(*)
! local variables
integer i,j,k,l,p,q,iw,iw1,ni
integer lensav,lenwrk
! allocatable arrays
real(prec), allocatable :: wsave(:)
real(prec), allocatable :: work(:)
if (nd.le.0) then
write(*,*)
write(*,'("Error(cfftnd): invalid number of dimensions : ",I8)') nd
write(*,*)
stop
end if
p=1
lensav=1
do i=1,nd
if (n(i).le.0) then
write(*,*)
write(*,'("Error(cfftnd): invalid n : ",I8)') n(i)
write(*,'(" for dimension ",I4)') i
write(*,*)
stop
end if
p=p*n(i)
lensav=max(lensav,2*n(i)+int(log(real(n(i),prec)))+4)
end do
lenwrk=2*p
allocate(wsave(lensav))
allocate(work(lenwrk))
if (sgn.gt.0) then
q=1
do i=1,nd
ni=n(i)
if (ni.gt.1) then
iw=ni+ni+1
iw1=iw+1
p=p/ni
call cfftmi(ni,wsave,lensav)
j=1
k=q*ni
do l=1,p
call cmfm1b(q,1,ni,q,c(j),work,wsave,wsave(iw),wsave(iw1))
j=j+k
end do
q=k
end if
end do
else
q=1
do i=1,nd
ni=n(i)
if (ni.gt.1) then
iw=ni+ni+1
iw1=iw+1
p=p/ni
call cfftmi(ni,wsave,lensav)
j=1
k=q*ni
do l=1,p
call cmfm1f(q,1,ni,q,c(j),work,wsave,wsave(iw),wsave(iw1))
j=j+k
end do
q=k
end if
end do
end if
deallocate(wsave,work)
return
end subroutine
subroutine cfftmi ( n, wsave, lensav )
!*******************************************************************************
!
!! CFFTMI: initialization for CFFTMB and CFFTMF.
!
! Discussion:
!
! CFFTMI initializes array WSAVE for use in its companion routines
! CFFTMB and CFFTMF. CFFTMI must be called before the first call
! to CFFTMB or CFFTMF, and after whenever the value of integer N changes.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Modified:
!
! 24 March 2005
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
! Input, integer N, the length of each sequence to be transformed.
! The transform is most efficient when N is a product of small primes.
!
! Input, integer LENSAV, the dimension of the WSAVE array. LENSAV must be
! at least 2*N + INT(LOG(REAL(N))) + 4.
!
! Output, real WSAVE(LENSAV), containing the prime factors of N and
! also containing certain trigonometric values which will be used in
! routines CFFTMB or CFFTMF.
!
!
use fftpack5
implicit none
integer lensav
integer iw1
integer n
real(prec) wsave(lensav)
if ( n == 1 ) then
return
end if
iw1 = n + n + 1
call mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) )
return
end
subroutine mcfti1 ( n, wa, fnf, fac )
!*******************************************************************************
!
!! MCFTI1 is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
real(prec) fac(*)
real(prec) fnf
integer ido
integer ip
integer iw
integer k1
integer l1
integer l2
integer n
integer nf
real(prec) wa(*)
!
! Get the factorization of N.
!
call factor ( n, nf, fac )
fnf = real ( nf, prec )
iw = 1
l1 = 1
!
! Set up the trigonometric tables.
!
do k1 = 1, nf
ip = int ( fac(k1) )
l2 = l1 * ip
ido = n / l2
call tables ( ido, ip, wa(iw) )
iw = iw + ( ip - 1 ) * ( ido + ido )
l1 = l2
end do
return
end
subroutine factor ( n, nf, fac )
!*******************************************************************************
!
!! FACTOR determines the factors of an integer.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Modified:
!
! 28 March 2005
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
! Input, integer N, the number for which factorization and other information
! is needed.
!
! Output, integer NF, the number of factors.
!
! Output, real FAC(*), a list of factors of N.
!
use fftpack5
implicit none
real(prec) fac(*)
integer j
integer n
integer nf
integer nl
integer nq
integer nr
integer ntry
nl = n
nf = 0
j = 0
do while ( 1 < nl )
j = j + 1
if ( j == 1 ) then
ntry = 4
else if ( j == 2 ) then
ntry = 2
else if ( j == 3 ) then
ntry = 3
else if ( j == 4 ) then
ntry = 5
else
ntry = ntry + 2
end if
do
nq = nl / ntry
nr = nl - ntry * nq
if ( nr /= 0 ) then
exit
end if
nf = nf + 1
fac(nf) = ntry
nl = nq
end do
end do
return
end
subroutine tables ( ido, ip, wa )
!*******************************************************************************
!
!! TABLES computes trigonometric tables needed by the FFT routines.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer ip
real(prec) arg1
real(prec) arg2
real(prec) arg3
real(prec) arg4
real(prec) argz
integer i
integer j
real(prec) tpi
real(prec) wa(ido,ip-1,2)
tpi = 8.0E+00_prec * atan ( 1.0E+00_prec )
argz = tpi / real ( ip, prec )
arg1 = tpi / real ( ido * ip, prec )
do j = 2, ip
arg2 = real ( j - 1, prec ) * arg1
do i = 1, ido
arg3 = real ( i - 1, prec ) * arg2
wa(i,j-1,1) = cos ( arg3 )
wa(i,j-1,2) = sin ( arg3 )
end do
if ( 5 < ip ) then
arg4 = real ( j - 1, prec ) * argz
wa(1,j-1,1) = cos ( arg4 )
wa(1,j-1,2) = sin ( arg4 )
end if
end do
return
end
subroutine cmfm1b ( lot, jump, n, inc, c, ch, wa, fnf, fac )
!*******************************************************************************
!
!! CMFM1B is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
complex(prec) c(*)
real(prec) ch(*)
real(prec) fac(*)
real(prec) fnf
integer ido
integer inc
integer ip
integer iw
integer jump
integer k1
integer l1
integer l2
integer lid
integer lot
integer n
integer na
integer nbr
integer nf
real(prec) wa(*)
nf = int ( fnf )
na = 0
l1 = 1
iw = 1
do k1 = 1, nf
ip = int ( fac(k1) )
l2 = ip * l1
ido = n / l2
lid = l1 * ido
nbr = 1 + na + 2 * min ( ip - 2, 4 )
if ( nbr == 1 ) then
call cmf2kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 2 ) then
call cmf2kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 3 ) then
call cmf3kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 4 ) then
call cmf3kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 5 ) then
call cmf4kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 6 ) then
call cmf4kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 7 ) then
call cmf5kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 8 ) then
call cmf5kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 9 ) then
call cmfgkb ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
1, lot, wa(iw) )
else if ( nbr == 10 ) then
call cmfgkb ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
jump, inc, wa(iw) )
end if
l1 = l2
iw = iw + ( ip - 1 ) * ( ido + ido )
if ( ip <= 5 ) then
na = 1 - na
end if
end do
return
end
subroutine cmfm1f ( lot, jump, n, inc, c, ch, wa, fnf, fac )
!*******************************************************************************
!
!! CMFM1F is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
complex(prec) c(*)
real(prec) ch(*)
real(prec) fac(*)
real(prec) fnf
integer ido
integer inc
integer ip
integer iw
integer jump
integer k1
integer l1
integer l2
integer lid
integer lot
integer n
integer na
integer nbr
integer nf
real(prec) wa(*)
nf = int ( fnf )
na = 0
l1 = 1
iw = 1
do k1 = 1, nf
ip = int ( fac(k1) )
l2 = ip * l1
ido = n / l2
lid = l1 * ido
nbr = 1 + na + 2 * min ( ip - 2, 4 )
if ( nbr == 1 ) then
call cmf2kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 2 ) then
call cmf2kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 3 ) then
call cmf3kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 4 ) then
call cmf3kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 5 ) then
call cmf4kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 6 ) then
call cmf4kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 7 ) then
call cmf5kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
else if ( nbr == 8 ) then
call cmf5kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
else if ( nbr == 9 ) then
call cmfgkf ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
1, lot, wa(iw) )
else if ( nbr == 10 ) then
call cmfgkf ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
jump, inc, wa(iw) )
end if
l1 = l2
iw = iw + ( ip - 1 ) * ( ido + ido )
if ( ip <= 5 ) then
na = 1 - na
end if
end do
return
end
subroutine cmf2kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF2KB is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,2)
real(prec) ch(2,in2,l1,2,ido)
real(prec) chold1
real(prec) chold2
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) ti2
real(prec) tr2
real(prec) wa(ido,1,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido .or. na == 1 ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch(1,m2,k,1,1) = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
ch(1,m2,k,2,1) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
ch(2,m2,k,1,1) = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
ch(2,m2,k,2,1) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
ch(2,m2,k,2,i) = wa(i,1,1)*ti2+wa(i,1,2)*tr2
ch(1,m2,k,2,i) = wa(i,1,1)*tr2-wa(i,1,2)*ti2
end do
end do
end do
else
do k = 1, l1
do m1 = 1, m1d, im1
chold1 = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
cc(1,m1,k,1,2) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
cc(1,m1,k,1,1) = chold1
chold2 = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
cc(2,m1,k,1,2) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
cc(2,m1,k,1,1) = chold2
end do
end do
end if
return
end
subroutine cmf2kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF2KF is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,2)
real(prec) ch(2,in2,l1,2,ido)
real(prec) chold1
real(prec) chold2
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) sn
real(prec) ti2
real(prec) tr2
real(prec) wa(ido,1,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2)
ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2)
ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2)
ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2)
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
ch(2,m2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2
ch(1,m2,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2
end do
end do
end do
else if ( na == 1 ) then
sn = 1.0E+00_prec / real ( 2 * l1, prec )
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch(1,m2,k,1,1) = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
ch(1,m2,k,2,1) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
ch(2,m2,k,1,1) = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
ch(2,m2,k,2,1) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
end do
end do
else
sn = 1.0E+00_prec / real ( 2 * l1, prec )
do k = 1, l1
do m1 = 1, m1d, im1
chold1 = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
cc(1,m1,k,1,2) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
cc(1,m1,k,1,1) = chold1
chold2 = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
cc(2,m1,k,1,2) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
cc(2,m1,k,1,1) = chold2
end do
end do
end if
return
end
subroutine cmf3kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF3KB is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,3)
real(prec) ch(2,in2,l1,3,ido)
real(prec) ci2
real(prec) ci3
real(prec) cr2
real(prec) cr3
real(prec) di2
real(prec) di3
real(prec) dr2
real(prec) dr3
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec), parameter :: taui = 0.866025403784439E+00_prec
real(prec), parameter :: taur = -0.5E+00_prec
real(prec) ti2
real(prec) tr2
real(prec) wa(ido,2,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido .or. na == 1 ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
cr2 = cc(1,m1,k,1,1)+taur*tr2
ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
ci2 = cc(2,m1,k,1,1)+taur*ti2
ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
cr3 = taui * (cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
ci3 = taui * (cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
ch(1,m2,k,2,1) = cr2-ci3
ch(1,m2,k,3,1) = cr2+ci3
ch(2,m2,k,2,1) = ci2+cr3
ch(2,m2,k,3,1) = ci2-cr3
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
cr2 = cc(1,m1,k,i,1)+taur*tr2
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
ci2 = cc(2,m1,k,i,1)+taur*ti2
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
dr2 = cr2-ci3
dr3 = cr2+ci3
di2 = ci2+cr3
di3 = ci2-cr3
ch(2,m2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2
ch(1,m2,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2
ch(2,m2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3
ch(1,m2,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3
end do
end do
end do
else
do k = 1, l1
do m1 = 1, m1d, im1
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
cr2 = cc(1,m1,k,1,1)+taur*tr2
cc(1,m1,k,1,1) = cc(1,m1,k,1,1)+tr2
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
ci2 = cc(2,m1,k,1,1)+taur*ti2
cc(2,m1,k,1,1) = cc(2,m1,k,1,1)+ti2
cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
cc(1,m1,k,1,2) = cr2-ci3
cc(1,m1,k,1,3) = cr2+ci3
cc(2,m1,k,1,2) = ci2+cr3
cc(2,m1,k,1,3) = ci2-cr3
end do
end do
end if
return
end
subroutine cmf3kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF3KF is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,3)
real(prec) ch(2,in2,l1,3,ido)
real(prec) ci2
real(prec) ci3
real(prec) cr2
real(prec) cr3
real(prec) di2
real(prec) di3
real(prec) dr2
real(prec) dr3
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) sn
real(prec), parameter :: taui = -0.866025403784439E+00_prec
real(prec), parameter :: taur = -0.5E+00_prec
real(prec) ti2
real(prec) tr2
real(prec) wa(ido,2,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
cr2 = cc(1,m1,k,1,1)+taur*tr2
ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
ci2 = cc(2,m1,k,1,1)+taur*ti2
ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
ch(1,m2,k,2,1) = cr2-ci3
ch(1,m2,k,3,1) = cr2+ci3
ch(2,m2,k,2,1) = ci2+cr3
ch(2,m2,k,3,1) = ci2-cr3
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
cr2 = cc(1,m1,k,i,1)+taur*tr2
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
ci2 = cc(2,m1,k,i,1)+taur*ti2
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
dr2 = cr2-ci3
dr3 = cr2+ci3
di2 = ci2+cr3
di3 = ci2-cr3
ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
end do
end do
end do
else if ( na == 1 ) then
sn = 1.0E+00_prec / real ( 3 * l1, prec )
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
cr2 = cc(1,m1,k,1,1)+taur*tr2
ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
ci2 = cc(2,m1,k,1,1)+taur*ti2
ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
ch(1,m2,k,2,1) = sn*(cr2-ci3)
ch(1,m2,k,3,1) = sn*(cr2+ci3)
ch(2,m2,k,2,1) = sn*(ci2+cr3)
ch(2,m2,k,3,1) = sn*(ci2-cr3)
end do
end do
else
sn = 1.0E+00_prec / real ( 3 * l1, prec )
do k = 1, l1
do m1 = 1, m1d, im1
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
cr2 = cc(1,m1,k,1,1)+taur*tr2
cc(1,m1,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
ci2 = cc(2,m1,k,1,1)+taur*ti2
cc(2,m1,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
cc(1,m1,k,1,2) = sn*(cr2-ci3)
cc(1,m1,k,1,3) = sn*(cr2+ci3)
cc(2,m1,k,1,2) = sn*(ci2+cr3)
cc(2,m1,k,1,3) = sn*(ci2-cr3)
end do
end do
end if
return
end
subroutine cmf4kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF4KB is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,4)
real(prec) ch(2,in2,l1,4,ido)
real(prec) ci2
real(prec) ci3
real(prec) ci4
real(prec) cr2
real(prec) cr3
real(prec) cr4
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) ti1
real(prec) ti2
real(prec) ti3
real(prec) ti4
real(prec) tr1
real(prec) tr2
real(prec) tr3
real(prec) tr4
real(prec) wa(ido,3,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido .or. na == 1 ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = tr2+tr3
ch(1,m2,k,3,1) = tr2-tr3
ch(2,m2,k,1,1) = ti2+ti3
ch(2,m2,k,3,1) = ti2-ti3
ch(1,m2,k,2,1) = tr1+tr4
ch(1,m2,k,4,1) = tr1-tr4
ch(2,m2,k,2,1) = ti1+ti4
ch(2,m2,k,4,1) = ti1-ti4
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
tr4 = cc(2,m1,k,i,4)-cc(2,m1,k,i,2)
tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
ti4 = cc(1,m1,k,i,2)-cc(1,m1,k,i,4)
tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
ch(1,m2,k,1,i) = tr2+tr3
cr3 = tr2-tr3
ch(2,m2,k,1,i) = ti2+ti3
ci3 = ti2-ti3
cr2 = tr1+tr4
cr4 = tr1-tr4
ci2 = ti1+ti4
ci4 = ti1-ti4
ch(1,m2,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2
ch(2,m2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2
ch(1,m2,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3
ch(2,m2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3
ch(1,m2,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4
ch(2,m2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4
end do
end do
end do
else
do k = 1, l1
do m1 = 1, m1d, im1
ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
cc(1,m1,k,1,1) = tr2+tr3
cc(1,m1,k,1,3) = tr2-tr3
cc(2,m1,k,1,1) = ti2+ti3
cc(2,m1,k,1,3) = ti2-ti3
cc(1,m1,k,1,2) = tr1+tr4
cc(1,m1,k,1,4) = tr1-tr4
cc(2,m1,k,1,2) = ti1+ti4
cc(2,m1,k,1,4) = ti1-ti4
end do
end do
end if
return
end
subroutine cmf4kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF4KF is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,4)
real(prec) ch(2,in2,l1,4,ido)
real(prec) ci2
real(prec) ci3
real(prec) ci4
real(prec) cr2
real(prec) cr3
real(prec) cr4
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) sn
real(prec) ti1
real(prec) ti2
real(prec) ti3
real(prec) ti4
real(prec) tr1
real(prec) tr2
real(prec) tr3
real(prec) tr4
real(prec) wa(ido,3,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = tr2+tr3
ch(1,m2,k,3,1) = tr2-tr3
ch(2,m2,k,1,1) = ti2+ti3
ch(2,m2,k,3,1) = ti2-ti3
ch(1,m2,k,2,1) = tr1+tr4
ch(1,m2,k,4,1) = tr1-tr4
ch(2,m2,k,2,1) = ti1+ti4
ch(2,m2,k,4,1) = ti1-ti4
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
tr4 = cc(2,m1,k,i,2)-cc(2,m1,k,i,4)
tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
ti4 = cc(1,m1,k,i,4)-cc(1,m1,k,i,2)
tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
ch(1,m2,k,1,i) = tr2+tr3
cr3 = tr2-tr3
ch(2,m2,k,1,i) = ti2+ti3
ci3 = ti2-ti3
cr2 = tr1+tr4
cr4 = tr1-tr4
ci2 = ti1+ti4
ci4 = ti1-ti4
ch(1,m2,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
ch(2,m2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
ch(1,m2,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
ch(2,m2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
ch(1,m2,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
ch(2,m2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
end do
end do
end do
else if ( na == 1 ) then
sn = 1.0E+00_prec / real ( 4 * l1, prec )
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = sn*(tr2+tr3)
ch(1,m2,k,3,1) = sn*(tr2-tr3)
ch(2,m2,k,1,1) = sn*(ti2+ti3)
ch(2,m2,k,3,1) = sn*(ti2-ti3)
ch(1,m2,k,2,1) = sn*(tr1+tr4)
ch(1,m2,k,4,1) = sn*(tr1-tr4)
ch(2,m2,k,2,1) = sn*(ti1+ti4)
ch(2,m2,k,4,1) = sn*(ti1-ti4)
end do
end do
else
sn = 1.0E+00_prec / real ( 4 * l1, prec )
do k = 1, l1
do m1 = 1, m1d, im1
ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
cc(1,m1,k,1,1) = sn*(tr2+tr3)
cc(1,m1,k,1,3) = sn*(tr2-tr3)
cc(2,m1,k,1,1) = sn*(ti2+ti3)
cc(2,m1,k,1,3) = sn*(ti2-ti3)
cc(1,m1,k,1,2) = sn*(tr1+tr4)
cc(1,m1,k,1,4) = sn*(tr1-tr4)
cc(2,m1,k,1,2) = sn*(ti1+ti4)
cc(2,m1,k,1,4) = sn*(ti1-ti4)
end do
end do
end if
return
end
subroutine cmf5kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF5KB is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,5)
real(prec) ch(2,in2,l1,5,ido)
real(prec) chold1
real(prec) chold2
real(prec) ci2
real(prec) ci3
real(prec) ci4
real(prec) ci5
real(prec) cr2
real(prec) cr3
real(prec) cr4
real(prec) cr5
real(prec) di2
real(prec) di3
real(prec) di4
real(prec) di5
real(prec) dr2
real(prec) dr3
real(prec) dr4
real(prec) dr5
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) ti2
real(prec) ti3
real(prec) ti4
real(prec) ti5
real(prec), parameter :: ti11 = 0.9510565162951536E+00_prec
real(prec), parameter :: ti12 = 0.5877852522924731E+00_prec
real(prec) tr2
real(prec) tr3
real(prec) tr4
real(prec) tr5
real(prec), parameter :: tr11 = 0.3090169943749474E+00_prec
real(prec), parameter :: tr12 = -0.8090169943749474E+00_prec
real(prec) wa(ido,4,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido .or. na == 1 ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
cr5 = ti11*tr5+ti12*tr4
ci5 = ti11*ti5+ti12*ti4
cr4 = ti12*tr5-ti11*tr4
ci4 = ti12*ti5-ti11*ti4
ch(1,m2,k,2,1) = cr2-ci5
ch(1,m2,k,5,1) = cr2+ci5
ch(2,m2,k,2,1) = ci2+cr5
ch(2,m2,k,3,1) = ci3+cr4
ch(1,m2,k,3,1) = cr3-ci4
ch(1,m2,k,4,1) = cr3+ci4
ch(2,m2,k,4,1) = ci3-cr4
ch(2,m2,k,5,1) = ci2-cr5
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
cr5 = ti11*tr5+ti12*tr4
ci5 = ti11*ti5+ti12*ti4
cr4 = ti12*tr5-ti11*tr4
ci4 = ti12*ti5-ti11*ti4
dr3 = cr3-ci4
dr4 = cr3+ci4
di3 = ci3+cr4
di4 = ci3-cr4
dr5 = cr2+ci5
dr2 = cr2-ci5
di5 = ci2-cr5
di2 = ci2+cr5
ch(1,m2,k,2,i) = wa(i,1,1) * dr2 - wa(i,1,2) * di2
ch(2,m2,k,2,i) = wa(i,1,1) * di2 + wa(i,1,2) * dr2
ch(1,m2,k,3,i) = wa(i,2,1) * dr3 - wa(i,2,2) * di3
ch(2,m2,k,3,i) = wa(i,2,1) * di3 + wa(i,2,2) * dr3
ch(1,m2,k,4,i) = wa(i,3,1) * dr4 - wa(i,3,2) * di4
ch(2,m2,k,4,i) = wa(i,3,1) * di4 + wa(i,3,2) * dr4
ch(1,m2,k,5,i) = wa(i,4,1) * dr5 - wa(i,4,2) * di5
ch(2,m2,k,5,i) = wa(i,4,1) * di5 + wa(i,4,2) * dr5
end do
end do
end do
else
do k = 1, l1
do m1 = 1, m1d, im1
ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
chold1 = cc(1,m1,k,1,1) + tr2 + tr3
chold2 = cc(2,m1,k,1,1) + ti2 + ti3
cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
cc(1,m1,k,1,1) = chold1
cc(2,m1,k,1,1) = chold2
cr5 = ti11*tr5 + ti12*tr4
ci5 = ti11*ti5 + ti12*ti4
cr4 = ti12*tr5 - ti11*tr4
ci4 = ti12*ti5 - ti11*ti4
cc(1,m1,k,1,2) = cr2-ci5
cc(1,m1,k,1,5) = cr2+ci5
cc(2,m1,k,1,2) = ci2+cr5
cc(2,m1,k,1,3) = ci3+cr4
cc(1,m1,k,1,3) = cr3-ci4
cc(1,m1,k,1,4) = cr3+ci4
cc(2,m1,k,1,4) = ci3-cr4
cc(2,m1,k,1,5) = ci2-cr5
end do
end do
end if
return
end
subroutine cmf5kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
!*******************************************************************************
!
!! CMF5KF is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer l1
real(prec) cc(2,in1,l1,ido,5)
real(prec) ch(2,in2,l1,5,ido)
real(prec) chold1
real(prec) chold2
real(prec) ci2
real(prec) ci3
real(prec) ci4
real(prec) ci5
real(prec) cr2
real(prec) cr3
real(prec) cr4
real(prec) cr5
real(prec) di2
real(prec) di3
real(prec) di4
real(prec) di5
real(prec) dr2
real(prec) dr3
real(prec) dr4
real(prec) dr5
integer i
integer im1
integer im2
integer k
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) sn
real(prec) ti2
real(prec) ti3
real(prec) ti4
real(prec) ti5
real(prec), parameter :: ti11 = -0.9510565162951536E+00_prec
real(prec), parameter :: ti12 = -0.5877852522924731E+00_prec
real(prec) tr2
real(prec) tr3
real(prec) tr4
real(prec) tr5
real(prec), parameter :: tr11 = 0.3090169943749474E+00_prec
real(prec), parameter :: tr12 = -0.8090169943749474E+00_prec
real(prec) wa(ido,4,2)
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
if ( 1 < ido ) then
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
cr5 = ti11*tr5+ti12*tr4
ci5 = ti11*ti5+ti12*ti4
cr4 = ti12*tr5-ti11*tr4
ci4 = ti12*ti5-ti11*ti4
ch(1,m2,k,2,1) = cr2-ci5
ch(1,m2,k,5,1) = cr2+ci5
ch(2,m2,k,2,1) = ci2+cr5
ch(2,m2,k,3,1) = ci3+cr4
ch(1,m2,k,3,1) = cr3-ci4
ch(1,m2,k,4,1) = cr3+ci4
ch(2,m2,k,4,1) = ci3-cr4
ch(2,m2,k,5,1) = ci2-cr5
end do
end do
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
cr5 = ti11*tr5+ti12*tr4
ci5 = ti11*ti5+ti12*ti4
cr4 = ti12*tr5-ti11*tr4
ci4 = ti12*ti5-ti11*ti4
dr3 = cr3-ci4
dr4 = cr3+ci4
di3 = ci3+cr4
di4 = ci3-cr4
dr5 = cr2+ci5
dr2 = cr2-ci5
di5 = ci2-cr5
di2 = ci2+cr5
ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
ch(1,m2,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
ch(2,m2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
ch(1,m2,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
ch(2,m2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
end do
end do
end do
else if ( na == 1 ) then
sn = 1.0E+00_prec / real ( 5 * l1, prec )
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2+tr3)
ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2+ti3)
cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
cr5 = ti11*tr5+ti12*tr4
ci5 = ti11*ti5+ti12*ti4
cr4 = ti12*tr5-ti11*tr4
ci4 = ti12*ti5-ti11*ti4
ch(1,m2,k,2,1) = sn*(cr2-ci5)
ch(1,m2,k,5,1) = sn*(cr2+ci5)
ch(2,m2,k,2,1) = sn*(ci2+cr5)
ch(2,m2,k,3,1) = sn*(ci3+cr4)
ch(1,m2,k,3,1) = sn*(cr3-ci4)
ch(1,m2,k,4,1) = sn*(cr3+ci4)
ch(2,m2,k,4,1) = sn*(ci3-cr4)
ch(2,m2,k,5,1) = sn*(ci2-cr5)
end do
end do
else
sn = 1.0E+00_prec / real ( 5 * l1, prec )
do k = 1, l1
do m1 = 1, m1d, im1
ti5 = cc(2,m1,k,1,2) - cc(2,m1,k,1,5)
ti2 = cc(2,m1,k,1,2) + cc(2,m1,k,1,5)
ti4 = cc(2,m1,k,1,3) - cc(2,m1,k,1,4)
ti3 = cc(2,m1,k,1,3) + cc(2,m1,k,1,4)
tr5 = cc(1,m1,k,1,2) - cc(1,m1,k,1,5)
tr2 = cc(1,m1,k,1,2) + cc(1,m1,k,1,5)
tr4 = cc(1,m1,k,1,3) - cc(1,m1,k,1,4)
tr3 = cc(1,m1,k,1,3) + cc(1,m1,k,1,4)
chold1 = sn * ( cc(1,m1,k,1,1) + tr2 + tr3 )
chold2 = sn * ( cc(2,m1,k,1,1) + ti2 + ti3 )
cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
cc(1,m1,k,1,1) = chold1
cc(2,m1,k,1,1) = chold2
cr5 = ti11 * tr5 + ti12 * tr4
ci5 = ti11 * ti5 + ti12 * ti4
cr4 = ti12 * tr5 - ti11 * tr4
ci4 = ti12 * ti5 - ti11 * ti4
cc(1,m1,k,1,2) = sn * ( cr2 - ci5 )
cc(1,m1,k,1,5) = sn * ( cr2 + ci5 )
cc(2,m1,k,1,2) = sn * ( ci2 + cr5 )
cc(2,m1,k,1,3) = sn * ( ci3 + cr4 )
cc(1,m1,k,1,3) = sn * ( cr3 - ci4 )
cc(1,m1,k,1,4) = sn * ( cr3 + ci4 )
cc(2,m1,k,1,4) = sn * ( ci3 - cr4 )
cc(2,m1,k,1,5) = sn * ( ci2 - cr5 )
end do
end do
end if
return
end
subroutine cmfgkb ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
ch, ch1, im2, in2, wa )
!*******************************************************************************
!
!! CMFGKB is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer ip
integer l1
integer lid
real(prec) cc(2,in1,l1,ip,ido)
real(prec) cc1(2,in1,lid,ip)
real(prec) ch(2,in2,l1,ido,ip)
real(prec) ch1(2,in2,lid,ip)
real(prec) chold1
real(prec) chold2
integer i
integer idlj
integer im1
integer im2
integer ipp2
integer ipph
integer j
integer jc
integer k
integer ki
integer l
integer lc
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) wa(ido,ip-1,2)
real(prec) wai
real(prec) war
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
ipp2 = ip + 2
ipph = ( ip + 1 ) / 2
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,j) = cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
ch1(2,m2,ki,j) = cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
end do
end do
end do
do j = 2, ipph
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
end do
end do
end do
do l = 2, ipph
lc = ipp2 - l
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,l) = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
cc1(1,m1,ki,lc) = wa(1,l-1,2) * ch1(1,m2,ki,ip)
cc1(2,m1,ki,l) = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
cc1(2,m1,ki,lc) = wa(1,l-1,2) * ch1(2,m2,ki,ip)
end do
end do
do j = 3, ipph
jc = ipp2 - j
idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
war = wa(1,idlj,1)
wai = wa(1,idlj,2)
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,l) = cc1(1,m1,ki,l) + war * ch1(1,m2,ki,j)
cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
cc1(2,m1,ki,l) = cc1(2,m1,ki,l) + war * ch1(2,m2,ki,j)
cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
end do
end do
end do
end do
if( 1 < ido .or. na == 1 ) then
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,j) = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
ch1(2,m2,ki,j) = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
end do
end do
end do
if ( ido == 1 ) then
return
end if
do i = 1, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
end do
end do
end do
do j = 2, ip
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
end do
end do
end do
do j = 2, ip
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
- wa(i,j-1,2) * ch(2,m2,k,i,j)
cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
+ wa(i,j-1,2) * ch(1,m2,k,i,j)
end do
end do
end do
end do
else
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
do m1 = 1, m1d, im1
chold1 = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
chold2 = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
cc1(1,m1,ki,j) = chold1
cc1(2,m1,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
cc1(2,m1,ki,j) = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
cc1(1,m1,ki,jc) = chold2
end do
end do
end do
end if
return
end
subroutine cmfgkf ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
ch, ch1, im2, in2, wa )
!*******************************************************************************
!
!! CMFGKF is an FFTPACK5 auxiliary routine.
!
! License:
!
! Licensed under the GNU General Public License (GPL).
! Copyright (C) 1995-2004, Scientific Computing Division,
! University Corporation for Atmospheric Research
!
! Author:
!
! Paul Swarztrauber
! Richard Valent
!
! Reference:
!
! Paul Swarztrauber,
! Vectorizing the Fast Fourier Transforms,
! in Parallel Computations,
! edited by G. Rodrigue,
! Academic Press, 1982.
!
! Paul Swarztrauber,
! Fast Fourier Transform Algorithms for Vector Computers,
! Parallel Computing, pages 45-63, 1984.
!
! Parameters:
!
use fftpack5
implicit none
integer ido
integer in1
integer in2
integer ip
integer l1
integer lid
real(prec) cc(2,in1,l1,ip,ido)
real(prec) cc1(2,in1,lid,ip)
real(prec) ch(2,in2,l1,ido,ip)
real(prec) ch1(2,in2,lid,ip)
real(prec) chold1
real(prec) chold2
integer i
integer idlj
integer im1
integer im2
integer ipp2
integer ipph
integer j
integer jc
integer k
integer ki
integer l
integer lc
integer lot
integer m1
integer m1d
integer m2
integer m2s
integer na
real(prec) sn
real(prec) wa(ido,ip-1,2)
real(prec) wai
real(prec) war
m1d = ( lot - 1 ) * im1 + 1
m2s = 1 - im2
ipp2 = ip + 2
ipph = ( ip + 1 ) / 2
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,j) = cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
ch1(2,m2,ki,j) = cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
end do
end do
end do
do j = 2, ipph
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
end do
end do
end do
do l = 2, ipph
lc = ipp2 - l
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,l) = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
cc1(1,m1,ki,lc) = - wa(1,l-1,2) * ch1(1,m2,ki,ip)
cc1(2,m1,ki,l) = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
cc1(2,m1,ki,lc) = - wa(1,l-1,2) * ch1(2,m2,ki,ip)
end do
end do
do j = 3, ipph
jc = ipp2 - j
idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
war = wa(1,idlj,1)
wai = -wa(1,idlj,2)
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,l) = cc1(1,m1,ki,l) + war * ch1(1,m2,ki,j)
cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
cc1(2,m1,ki,l) = cc1(2,m1,ki,l) + war * ch1(2,m2,ki,j)
cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
end do
end do
end do
end do
if ( 1 < ido ) then
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,j) = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
ch1(2,m2,ki,j) = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
end do
end do
end do
do i = 1, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
end do
end do
end do
do j = 2, ip
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
end do
end do
end do
do j = 2, ip
do i = 2, ido
do k = 1, l1
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
+ wa(i,j-1,2) * ch(2,m2,k,i,j)
cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
- wa(i,j-1,2) * ch(1,m2,k,i,j)
end do
end do
end do
end do
else if ( na == 1 ) then
sn = 1.0E+00_prec / real ( ip * l1, prec )
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,1) = sn * cc1(1,m1,ki,1)
ch1(2,m2,ki,1) = sn * cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
ch1(1,m2,ki,j) = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
ch1(2,m2,ki,j) = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
ch1(1,m2,ki,jc) = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
ch1(2,m2,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
end do
end do
end do
else
sn = 1.0E+00_prec / real ( ip * l1, prec )
do ki = 1, lid
m2 = m2s
do m1 = 1, m1d, im1
m2 = m2 + im2
cc1(1,m1,ki,1) = sn * cc1(1,m1,ki,1)
cc1(2,m1,ki,1) = sn * cc1(2,m1,ki,1)
end do
end do
do j = 2, ipph
jc = ipp2 - j
do ki = 1, lid
do m1 = 1, m1d, im1
chold1 = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
chold2 = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
cc1(1,m1,ki,j) = chold1
cc1(2,m1,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
cc1(2,m1,ki,j) = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
cc1(1,m1,ki,jc) = chold2
end do
end do
end do
end if
return
end
elk-7.2.42/src/PaxHeaders.21776/eos 0000644 0000000 0000000 00000000132 14061636515 013433 x ustar 00 30 mtime=1623670093.500103805
30 atime=1623670093.481103823
30 ctime=1623670093.500103805
elk-7.2.42/src/eos/ 0000755 0025044 0025044 00000000000 14061636515 015545 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/eos/PaxHeaders.21776/Makefile 0000644 0000000 0000000 00000000132 14061636515 015150 x ustar 00 30 mtime=1623670093.483103821
30 atime=1623670093.482103822
30 ctime=1623670093.483103821
elk-7.2.42/src/eos/Makefile 0000644 0025044 0025044 00000001346 14061636515 017211 0 ustar 00dewhurst dewhurst 0000000 0000000
include ../../make.inc
#-------------------------------------------------------------------------------
# Suffix rules
#-------------------------------------------------------------------------------
.SUFFIXES: .o .f90
.f90.o:
$(F90) $(F90_OPTS) -c $<
#-------------------------------------------------------------------------------
# Source files
#-------------------------------------------------------------------------------
SRC = modmain.f90 eos.f90 eveos.f90 pveos.f90 readinput.f90 getedata.f90 \
fitdata.f90 output.f90 minf_nm.f90 fmin_nm.f90
OBJ = $(SRC:.f90=.o)
EXE = eos
eos: $(OBJ)
$(F90) $(F90_OPTS) -o $(EXE) $(OBJ)
clean:
rm -f *.o *.mod *~ fort.* ifc* *.gcno *.OUT gmon.out $(EXE)
spaces:
../rmspaces $(SRC)
elk-7.2.42/src/eos/PaxHeaders.21776/README 0000644 0000000 0000000 00000000127 14061636515 014374 x ustar 00 29 mtime=1623670093.48410382
29 atime=1623670093.48410382
29 ctime=1623670093.48410382
elk-7.2.42/src/eos/README 0000644 0025044 0025044 00000002544 14061636515 016432 0 ustar 00dewhurst dewhurst 0000000 0000000 +---------------------------+
| EOS Version 1.4.0 |
+---------------------------+
Equation of state (EOS) program for fitting energy-volume data. The following
variables are set in the file eos.in:
cname : name of crystal up to 256 characters
natoms : number of atoms in unit cell
etype : equation of state type (see below)
vplt1, vplt2, nvplt : volume interval over which to plot energy, pressure etc.
as well as the number of points in the plot
nevpt : number of energy-volume points to be inputted
vpt(i) ept(i) : energy-volume points (atomic units)
Note that the input units are atomic - Bohr and Hartree (NOT Rydbergs).
The equations of state currently implemented are:
1. Universal EOS (Vinet P et al., J. Phys.: Condens. Matter 1, p1941 (1989))
2. Murnaghan EOS (Murnaghan F D, Am. J. Math. 49, p235 (1937))
3. Birch-Murnaghan 3rd-order EOS (Birch F, Phys. Rev. 71, p809 (1947))
4. Birch-Murnaghan 4th-order EOS
5. Natural strain 3rd-order EOS (Poirier J-P and Tarantola A, Phys. Earth
Planet Int. 109, p1 (1998))
6. Natural strain 4th-order EOS
7. Cubic polynomial in (V-V0)
--------------------------------------------------------------------------------
J. K. Dewhurst
August 2005
elk-7.2.42/src/eos/PaxHeaders.21776/eos.f90 0000644 0000000 0000000 00000000132 14061636515 014616 x ustar 00 30 mtime=1623670093.486103818
30 atime=1623670093.486103818
30 ctime=1623670093.486103818
elk-7.2.42/src/eos/eos.f90 0000644 0025044 0025044 00000000517 14061636515 016656 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
program eos
use modmain
implicit none
call readinput
call getedata(etype,nparam,ename,pname)
call fitdata
call output
stop
end program
elk-7.2.42/src/eos/PaxHeaders.21776/eos.in 0000644 0000000 0000000 00000000132 14061636515 014626 x ustar 00 30 mtime=1623670093.487103817
30 atime=1623670093.487103817
30 ctime=1623670093.487103817
elk-7.2.42/src/eos/eos.in 0000644 0025044 0025044 00000000635 14061636515 016667 0 ustar 00dewhurst dewhurst 0000000 0000000 "Silicon" : cname
2 : natoms
1 : etype
140.0 450.0 1000 : vplt1, vplt2, nvplt
8 : nevpt
165.8207473 -578.0660968
196.8383062 -578.1728409
231.5010189 -578.2305598
270.0113940 -578.2548962
312.5719400 -578.2566194
359.3851654 -578.2453281
410.6535788 -578.2253154
466.5796888 -578.2028836
elk-7.2.42/src/eos/PaxHeaders.21776/eveos.f90 0000644 0000000 0000000 00000000132 14061636515 015151 x ustar 00 30 mtime=1623670093.489103815
30 atime=1623670093.489103815
30 ctime=1623670093.489103815
elk-7.2.42/src/eos/eveos.f90 0000644 0025044 0025044 00000004556 14061636515 017220 0 ustar 00dewhurst dewhurst 0000000 0000000 real(8) function eveos(etype,param,v)
implicit none
! arguments
integer, intent(in) :: etype
real(8), intent(in) :: param(*)
real(8), intent(in) :: v
! local variables
real(8) v0,e0,b0,b0p,b0pp
real(8) t1,t2,t3,t4,t5,t6,t7
eveos=0.d0
select case(etype)
case(1)
! Universal equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
if (v0.lt.1.d-5) v0=1.d-5
if (abs(b0p-1.d0).lt.1.d-5) b0p=b0p+1.d-5
t1=b0*v0
t2=b0p-1.d0
t3=(v/v0)**(1.d0/3.d0)
t4=exp(-3.d0/2.d0*t2*(-1.d0+t3))
t5=t2**2
t6=1.d0/t5
eveos=-2.d0*t1*t4*(3.d0*t3*b0p-3.d0*t3+5.d0-3.d0*b0p)*t6+4.d0*t1*t6+e0
case(2)
! Murnaghan equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
if (v0.lt.1.d-5) v0=1.d-5
if (abs(b0p).lt.1.d-5) b0p=1.d-5
if (abs(b0p-1.d0).lt.1.d-5) b0p=b0p+1.d-5
t1=(v0/v)**b0p
t2=1.d0/(b0p-1.d0)
eveos=b0*(b0p-1.d0+t1)/b0p*t2*v-b0*v0*t2+e0
case(3)
! Birch-Murnaghan third-order equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
if (v0.lt.1.d-5) v0=1.d-5
t1=(v0/v)**(1.d0/3.d0)
t2=t1**2
t3=t2-1.d0
eveos=9.d0/8.d0*b0*v0*t3**2*(b0p*t3/2.d0-2.d0*t2+3.d0)+e0
case(4)
! Birch-Murnaghan fourth-order equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
b0pp=param(5)
if (v0.lt.1.d-5) v0=1.d-5
t1=(v0/v)**(1.d0/3.d0)
t2=t1**2
t3=t2-1.d0
t4=t3**2/4.d0
t5=b0p**2
eveos=3.d0/8.d0*b0*v0*t4*(9.d0*t4*b0*b0pp+9.d0*t4*t5-63.d0*t4*b0p+143.d0*t4 &
+6.d0*b0p*t3-24.d0*t2+36.d0)+e0
case(5)
! Natural strain third-order equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
if (v0.lt.1.d-5) v0=1.d-5
t1=b0*v0
t2=log(v0/v)
t3=t2**2
t4=t3*t2
eveos=t1*t3/2.d0+t1*t4*b0p/6.d0-t1*t4/3.d0+e0
case(6)
! Natural strain fourth-order equation of state
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
b0pp=param(5)
if (v0.lt.1.d-5) v0=1.d-5
t1=b0*v0
t2=log(v0/v)
t3=t2**2
t4=t3**2
t5=b0**2
t6=b0p**2
t7=t3*t2
eveos=t1*t4/8.d0+t5*v0*t4*b0pp/24.d0-t1*t4*b0p/8.d0+t1*t4*t6/24.d0 &
+t1*t7*b0p/6.d0-t1*t7/3.d0+t1*t3/2.d0+e0
case(7)
! cubic polynomial
v0=param(1)
e0=param(2)
b0=param(3)
b0p=param(4)
if (v0.lt.1.d-5) v0=1.d-5
t1=v0**2
t2=v0-v
t3=t2**2
eveos=(1.d0+b0p)*b0/t1*t3*t2/6.d0+b0/v0*t3/2.d0+e0
case default
write(*,*)
write(*,'("Error(eveos): etype not defined : ",I4)') etype
write(*,*)
stop
end select
return
end function
elk-7.2.42/src/eos/PaxHeaders.21776/fitdata.f90 0000644 0000000 0000000 00000000132 14061636515 015444 x ustar 00 30 mtime=1623670093.490103815
30 atime=1623670093.490103815
30 ctime=1623670093.490103815
elk-7.2.42/src/eos/fitdata.f90 0000644 0025044 0025044 00000001732 14061636515 017504 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine fitdata
use modmain
implicit none
! local variables
integer, parameter :: maxit=1000000
integer i,iter
real(8), parameter :: eps=1.d-14
! automatic arrays
real(8) x(nparam,nparam+1)
! initial guess: it is assumed that param(1)=V0, param(2)=E0 and param(3)=B0
x(:,1)=0.d0
x(1,1)=vpt(1)
x(2,1)=ept(1)
x(3,1)=0.003d0
! fit V0 and E0
do i=1,nparam
x(:,i+1)=x(:,1)
end do
x(1,2)=x(1,2)+1.d0
x(2,3)=x(2,3)+0.1d0
call minf_nm(nparam,x,maxit,iter,eps)
! fit V0, E0 and B0
do i=1,nparam
x(:,i+1)=x(:,1)
end do
x(1,2)=x(1,2)+1.d0
x(2,3)=x(2,3)+0.1d0
x(3,4)=x(3,4)+0.001d0
call minf_nm(nparam,x,maxit,iter,eps)
! fit everything
do i=1,nparam
x(:,i+1)=x(:,1)
x(i,i+1)=x(i,i+1)+0.1d0
end do
call minf_nm(nparam,x,maxit,iter,eps)
popt(1:nparam)=x(1:nparam,1)
return
end subroutine
elk-7.2.42/src/eos/PaxHeaders.21776/fmin_nm.f90 0000644 0000000 0000000 00000000132 14061636515 015453 x ustar 00 30 mtime=1623670093.492103813
30 atime=1623670093.492103813
30 ctime=1623670093.492103813
elk-7.2.42/src/eos/fmin_nm.f90 0000644 0025044 0025044 00000000746 14061636515 017517 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
real(8) function fmin_nm(x)
use modmain
implicit none
! arguments
real(8), intent(in) :: x
! local variables
integer i
real(8) sum
! external functions
real(8) eveos
external eveos
sum=0.d0
do i=1,nevpt
sum=sum+(eveos(etype,x,vpt(i))-ept(i))**2
end do
fmin_nm=sum
return
end function
elk-7.2.42/src/eos/PaxHeaders.21776/getedata.f90 0000644 0000000 0000000 00000000132 14061636515 015606 x ustar 00 30 mtime=1623670093.493103812
30 atime=1623670093.493103812
30 ctime=1623670093.493103812
elk-7.2.42/src/eos/getedata.f90 0000644 0025044 0025044 00000003251 14061636515 017644 0 ustar 00dewhurst dewhurst 0000000 0000000 subroutine getedata(etype,nparam,ename,pname)
! get eos name and number of parameters
implicit none
! arguments
integer, intent(in) :: etype
integer, intent(out) :: nparam
character(256), intent(out) :: ename(2)
character(256), intent(out) :: pname(*)
select case(etype)
case(1)
ename(1)="Universal EOS"
ename(2)="Vinet P et al., J. Phys.: Condens. Matter 1, p1941 (1989)"
nparam=4
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
case(2)
ename(1)="Murnaghan EOS"
ename(2)="Murnaghan F D, Am. J. Math. 49, p235 (1937)"
nparam=4
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
case(3)
ename(1)="Birch-Murnaghan 3rd-order EOS"
ename(2)="Birch F, Phys. Rev. 71, p809 (1947)"
nparam=4
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
case(4)
ename(1)="Birch-Murnaghan 4th-order EOS"
ename(2)="Birch F, Phys. Rev. 71, p809 (1947)"
nparam=5
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
pname(5)="B0''"
case(5)
ename(1)="Natural strain 3rd-order EOS"
ename(2)="Poirier J-P and Tarantola A, Phys. Earth Planet Int. 109, p1 (1998)"
nparam=4
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
case(6)
ename(1)="Natural strain 4th-order EOS"
ename(2)="Poirier J-P and Tarantola A, Phys. Earth Planet Int. 109, p1 (1998)"
nparam=5
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
pname(5)="B0''"
case(7)
ename(1)="Cubic polynomial in (V-V0)"
ename(2)=""
nparam=4
pname(1)="V0"
pname(2)="E0"
pname(3)="B0"
pname(4)="B0'"
case default
write(*,*)
write(*,'("Error(getedata): etype not defined : ",I4)') etype
write(*,*)
stop
end select
return
end subroutine
elk-7.2.42/src/eos/PaxHeaders.21776/minf_nm.f90 0000644 0000000 0000000 00000000127 14061636515 015457 x ustar 00 29 mtime=1623670093.49510381
29 atime=1623670093.49510381
29 ctime=1623670093.49510381
elk-7.2.42/src/eos/minf_nm.f90 0000644 0025044 0025044 00000003712 14061636515 017513 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007 J. K. Dewhurst and D. W. H. Rankin.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine minf_nm(n,x,maxit,iter,eps)
implicit none
! arguments
integer, intent(in) :: n
real(8), intent(inout) :: x(n,n+1)
integer, intent(in) :: maxit
integer, intent(out) :: iter
real(8), intent(in) :: eps
! local variables
integer i,j,il,iu
! Nelder-Mead parmeters
real(8), parameter :: alpha=1.d0,gamma=2.d0
real(8), parameter :: beta=0.5d0,sigma=0.5d0
real(8) fr,fe,fc,sum,t1
! automatic arrays
real(8) f(n+1),xm(n),xr(n),xe(n),xc(n)
! external functions
real(8) fmin_nm
external fmin_nm
if (n.lt.0) then
write(*,*)
write(*,'("Error(minf_nm): n <= 0 : ",I8)') n
write(*,*)
stop
end if
! evaluate the function at each vertex
do i=1,n+1
f(i)=fmin_nm(x(:,i))
end do
iter=0
10 continue
iter=iter+1
if (iter.ge.maxit) return
! find the lowest and highest vertex
il=1
iu=1
do i=2,n+1
if (f(i).lt.f(il)) il=i
if (f(i).gt.f(iu)) iu=i
end do
! check for convergence
if ((f(iu)-f(il)).lt.eps) return
! compute the mean of the n lowest vertices
t1=1.d0/dble(n)
do i=1,n
sum=0.d0
do j=1,iu-1
sum=sum+x(i,j)
end do
do j=iu+1,n+1
sum=sum+x(i,j)
end do
xm(i)=t1*sum
end do
xr(:)=xm(:)+alpha*(xm(:)-x(:,iu))
fr=fmin_nm(xr)
if (f(il).gt.fr) goto 30
if ((f(il).le.fr).and.(fr.lt.f(iu))) then
! reflection
x(:,iu)=xr(:)
f(iu)=fr
goto 10
else
goto 40
end if
30 continue
xe(:)=xm(:)+gamma*(xr(:)-xm(:))
fe=fmin_nm(xe)
if (fr.gt.fe) then
! expansion
x(:,iu)=xe(:)
f(iu)=fe
else
! reflection
x(:,iu)=xr(:)
f(iu)=fr
end if
goto 10
40 continue
xc(:)=xm(:)+beta*(x(:,iu)-xm(:))
fc=fmin_nm(xc)
if (fc.lt.f(iu)) then
! contraction
x(:,iu)=xc(:)
f(iu)=fc
goto 10
end if
! shrinkage
do j=1,il-1
x(:,j)=x(:,il)+sigma*(x(:,j)-x(:,il))
f(j)=fmin_nm(x(1,j))
end do
do j=il+1,n+1
x(:,j)=x(:,il)+sigma*(x(:,j)-x(:,il))
f(j)=fmin_nm(x(1,j))
end do
goto 10
return
end subroutine
elk-7.2.42/src/eos/PaxHeaders.21776/modmain.f90 0000644 0000000 0000000 00000000132 14061636515 015454 x ustar 00 30 mtime=1623670093.496103809
30 atime=1623670093.496103809
30 ctime=1623670093.496103809
elk-7.2.42/src/eos/modmain.f90 0000644 0025044 0025044 00000002762 14061636515 017520 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modmain
! crystal name
character(256) cname
! number of atoms
integer natoms
! EOS type
integer etype
! number of volume points to plot
integer nvplt
! volume plot range
real(8) vplt1,vplt2
! number of energy data points to fit
integer nevpt
! volume and energy data point sets
real(8), allocatable :: vpt(:)
real(8), allocatable :: ept(:)
! maximum number of parameters for an EOS
integer, parameter :: maxparam=100
! number of parameters
integer nparam
! EOS name
character(256) ename(2)
! optimized parameter set
real(8) popt(maxparam)
! parameter names
character(256) pname(maxparam)
!-----------------------------!
! numerical constants !
!-----------------------------!
real(8), parameter :: pi=3.1415926535897932385d0
real(8), parameter :: twopi=6.2831853071795864769d0
! CODATA 2006 constants
! Bohr in SI units
real(8), parameter :: bohr_si=0.52917720859d-10
! electron mass in SI units
real(8), parameter :: emass_si=9.10938215d-31
! atomic unit of time in SI units
real(8), parameter :: autime_si=2.418884326505d-17
! atomic pressure unit in GPa
real(8), parameter :: aupress_gpa=1.d-9*emass_si/(bohr_si*autime_si**2)
!---------------------------------!
! miscellaneous variables !
!---------------------------------!
! code version
integer version(3)
data version /1,4,0/
end module
elk-7.2.42/src/eos/PaxHeaders.21776/output.f90 0000644 0000000 0000000 00000000132 14061636515 015370 x ustar 00 30 mtime=1623670093.498103807
30 atime=1623670093.498103807
30 ctime=1623670093.498103807
elk-7.2.42/src/eos/output.f90 0000644 0025044 0025044 00000005056 14061636515 017433 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine output
use modmain
implicit none
! local variables
integer ip,ipt,iplt
real(8) v
! external functions
real(8) eveos,pveos
external eveos,pveos
! output parameters
open(60,file='PARAM.OUT')
write(60,*)
write(60,'(A)') trim(cname)
write(60,*)
write(60,'(A)') trim(ename(1))
write(60,'(A)') trim(ename(2))
write(60,*)
write(60,'("(Default units are atomic: Hartree, Bohr etc.) ")')
write(60,*)
do ip=1,nparam
write(60,'(" ",A,T20,"=",T30,G18.10)') trim(pname(ip)),popt(ip)
end do
write(60,*)
do ip=1,nparam
if (trim(pname(ip)).eq."B0") then
write(60,'(" B0 (GPa)",T20,"=",T30,G18.10)') popt(ip)*aupress_gpa
end if
if (trim(pname(ip)).eq."B0''") then
write(60,'(A4," (/GPa)",T20,"=",T30,G18.10)') "B0''",popt(ip)/aupress_gpa
end if
end do
write(60,*)
close(60)
! output energy vs volume per atom at data points
open(60,file='EVPAP.OUT')
do ipt=1,nevpt
write(60,*) vpt(ipt)/dble(natoms),ept(ipt)/dble(natoms)
end do
close(60)
! output energy vs volume per atom over volume interval
open(60,file='EVPAI.OUT')
do iplt=1,nvplt
v=(vplt2-vplt1)*dble(iplt)/dble(nvplt)+vplt1
write(60,*) v/dble(natoms),eveos(etype,popt,v)/dble(natoms)
end do
close(60)
! output pressure vs volume per atom at data points
open(60,file='PVPAP.OUT')
do ipt=1,nevpt
write(60,*) vpt(ipt)/dble(natoms),pveos(etype,popt,vpt(ipt))*aupress_gpa
end do
close(60)
! output pressure vs volume per atom over volume interval
open(60,file='PVPAI.OUT')
do iplt=1,nvplt
v=(vplt2-vplt1)*dble(iplt)/dble(nvplt)+vplt1
write(60,*) v/dble(natoms),pveos(etype,popt,v)*aupress_gpa
end do
close(60)
! output enthalpy vs pressure per atom over volume interval
open(60,file='HPPAI.OUT')
do iplt=1,nvplt
v=(vplt2-vplt1)*dble(iplt)/dble(nvplt)+vplt1
write(60,*) pveos(etype,popt,v)*aupress_gpa, &
(eveos(etype,popt,v)+pveos(etype,popt,v)*v)/dble(natoms)
end do
close(60)
write(*,*)
write(*,'("All units are atomic unless otherwise stated")')
write(*,'("EOS parameters written to PARAM.OUT")')
write(*,'("Energy-volume per atom at data points written to EVPAP.OUT")')
write(*,'("Energy-volume per atom over interval written to EVPAI.OUT")')
write(*,'("Pressure(GPa)-volume per atom at data points written to PVPAP.OUT")')
write(*,'("Pressure(GPa)-volume per atom over interval written to PVPAI.OUT")')
write(*,'("Enthalpy-pressure(GPa) per atom over interval written to HPPAI.OUT")')
write(*,*)
return
end subroutine
elk-7.2.42/src/eos/PaxHeaders.21776/pveos.f90 0000644 0000000 0000000 00000000132 14061636515 015164 x ustar 00 30 mtime=1623670093.499103806
30 atime=1623670093.499103806
30 ctime=1623670093.499103806
elk-7.2.42/src/eos/pveos.f90 0000644 0025044 0025044 00000000661 14061636515 017224 0 ustar 00dewhurst dewhurst 0000000 0000000 real(8) function pveos(etype,param,v)
! pressure-volume equation of state function
implicit none
! arguments
integer, intent(in) :: etype
real(8), intent(in) :: param(*)
real(8), intent(in) :: v
! local variables
real(8) vm,vp,pm,pp,dv
! external functions
real(8) eveos
external eveos
! use central differences
dv=1.d-3
vm=v-dv
vp=v+dv
pm=eveos(etype,param,vm)
pp=eveos(etype,param,vp)
pveos=-(pp-pm)/(2.d0*dv)
return
end function
elk-7.2.42/src/eos/PaxHeaders.21776/readinput.f90 0000644 0000000 0000000 00000000132 14061636515 016023 x ustar 00 30 mtime=1623670093.501103804
30 atime=1623670093.501103804
30 ctime=1623670093.501103804
elk-7.2.42/src/eos/readinput.f90 0000644 0025044 0025044 00000001440 14061636515 020057 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine readinput
use modmain
implicit none
! local variables
integer ipt
open(50,file='eos.in',action='READ',status='OLD',form='FORMATTED')
read(50,*) cname
read(50,*) natoms
if (natoms.le.0) then
write(*,*)
write(*,'("Error(readinput): natoms <= 0 : ",I8)') natoms
write(*,*)
stop
end if
read(50,*) etype
read(50,*) vplt1,vplt2,nvplt
read(50,*) nevpt
if (nevpt.le.0) then
write(*,*)
write(*,'("Error(readinput): nevpt <= 0 : ",I8)') nevpt
write(*,*)
stop
end if
allocate(vpt(nevpt),ept(nevpt))
do ipt=1,nevpt
read(50,*) vpt(ipt),ept(ipt)
end do
close(50)
return
end subroutine
elk-7.2.42/src/PaxHeaders.21776/spacegroup 0000644 0000000 0000000 00000000130 14061636515 015013 x ustar 00 29 mtime=1623670093.53810377
30 atime=1623670093.508103798
29 ctime=1623670093.53810377
elk-7.2.42/src/spacegroup/ 0000755 0025044 0025044 00000000000 14061636515 017127 5 ustar 00dewhurst dewhurst 0000000 0000000 elk-7.2.42/src/spacegroup/PaxHeaders.21776/spacegroup.in 0000644 0000000 0000000 00000000132 14061636515 017572 x ustar 00 30 mtime=1623670093.510103796
30 atime=1623670093.509103797
30 ctime=1623670093.510103796
elk-7.2.42/src/spacegroup/spacegroup.in 0000644 0025044 0025044 00000001017 14061636515 021626 0 ustar 00dewhurst dewhurst 0000000 0000000 'Bmab' : hrmg
10.0605232 10.0605232 24.972729 : a, b, c
90.0 90.0 90.0 : bc, ac, ab
1 1 1 : ncell
.true. : primcell
3 : nspecies
'La' : spsymb
1 : nwpos
0.0000 0.0000 0.3608 : wpos
'Cu'
1
0.0000 0.0000 0.0000
'O'
2
0.2500 0.2500 0.0000
0.0000 0.0000 0.1820
elk-7.2.42/src/spacegroup/PaxHeaders.21776/Makefile 0000644 0000000 0000000 00000000132 14061636515 016532 x ustar 00 30 mtime=1623670093.511103795
30 atime=1623670093.511103795
30 ctime=1623670093.511103795
elk-7.2.42/src/spacegroup/Makefile 0000644 0025044 0025044 00000002167 14061636515 020575 0 ustar 00dewhurst dewhurst 0000000 0000000
include ../../make.inc
#-------------------------------------------------------------------------------
# Suffix rules
#-------------------------------------------------------------------------------
.SUFFIXES: .o .f90
.f90.o:
$(F90) $(F90_OPTS) -c $<
#-------------------------------------------------------------------------------
# Source files
#-------------------------------------------------------------------------------
SRC_modules = modmain.f90
SRC_main = main.f90
SRC_routines = readinput.f90 gencrystal.f90 sgsymb.f90 seitzgen.f90 \
gengroup.f90 seitzeq.f90 seitzmul.f90 writegeom.f90 geomplot.f90 \
findprimcell.f90 r3frac.f90 r3mv.f90 r3cross.f90 r3minv.f90 r3mm.f90
SRC = $(SRC_modules) $(SRC_main) $(SRC_routines)
OBJ = $(SRC:.f90=.o)
EXE = spacegroup
spacegroup: $(OBJ)
$(F90) $(F90_OPTS) -o $(EXE) $(OBJ)
clean:
rm -f *.o *.mod *~ fort.* ifc* *.gcno *.OUT *.xsf *.ascii gmon.out \
*.aux *.dvi *.log *.pdf *.tex *.toc *.out $(EXE)
doc:
../protex -s $(SRC_main) $(SRC_modules) $(SRC_routines) > spacegroup.tex
pdflatex spacegroup;pdflatex spacegroup;pdflatex spacegroup
spaces:
../rmspaces $(SRC)
elk-7.2.42/src/spacegroup/PaxHeaders.21776/findprimcell.f90 0000644 0000000 0000000 00000000132 14061636515 020062 x ustar 00 30 mtime=1623670093.513103793
30 atime=1623670093.512103794
30 ctime=1623670093.513103793
elk-7.2.42/src/spacegroup/findprimcell.f90 0000644 0025044 0025044 00000007356 14061636515 022132 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: findprimcell
! !INTERFACE:
subroutine findprimcell
! !USES:
use modmain
! !DESCRIPTION:
! This routine finds the smallest primitive cell which produces the same
! crystal structure as the conventional cell. This is done by searching
! through all the vectors which connect atomic positions and finding those
! which leave the crystal structure invariant. Of these, the three shortest
! which produce a non-zero unit cell volume are chosen.
!
! !REVISION HISTORY:
! Created April 2007 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,js,ia,ja,ka,na
integer i1,i2,i3,i,j,n
real(8) v1(3),v2(3),v3(3)
real(8) t1,t2
! allocatable arrays
real(8), allocatable :: dp(:)
real(8), allocatable :: vp(:,:)
do is=1,nspecies
do ia=1,natoms(is)
! make sure all atomic coordinates are in [0,1)
call r3frac(epslat,atposl(:,ia,is))
! determine atomic Cartesian coordinates
call r3mv(avec,atposl(:,ia,is),atposc(:,ia,is))
end do
end do
! find the smallest set of atoms
is=1
do js=1,nspecies
! if a species has only one atom the cell must be primitive
if (natoms(js).eq.1) return
if (natoms(js).lt.natoms(is)) is=js
end do
n=27*natoms(is)
allocate(dp(n),vp(3,n))
! generate set of possible lattice vectors
n=0
do ia=1,natoms(is)
v1(:)=atposl(:,ia,is)-atposl(:,1,is)
do i1=-1,1
v2(1)=v1(1)+dble(i1)
do i2=-1,1
v2(2)=v1(2)+dble(i2)
do i3=-1,1
v2(3)=v1(3)+dble(i3)
t1=abs(v2(1))+abs(v2(2))+abs(v2(3))
if (t1.lt.epslat) goto 20
! check if vector v2 leaves conventional cell invariant
do js=1,nspecies
do ja=1,natoms(js)
v3(:)=atposl(:,ja,js)+v2(:)
call r3frac(epslat,v3)
do ka=1,natoms(js)
! check both positions and magnetic fields are the same
t1=sum(abs(atposl(:,ka,js)-v3(:)))
t2=sum(abs(bfcmt0(:,ja,js)-bfcmt0(:,ka,js)))
if ((t1.lt.epslat).and.(t2.lt.epslat)) goto 10
end do
! atom ja has no equivalent under translation by v2
goto 20
10 continue
end do
end do
! cell invariant under translation by v2, so add to list
n=n+1
call r3mv(avec,v2,vp(:,n))
dp(n)=sqrt(vp(1,n)**2+vp(2,n)**2+vp(3,n)**2)
20 continue
end do
end do
end do
end do
if (n.eq.0) then
write(*,*)
write(*,'("Error(findprimcell): cannot find any lattice vectors")')
write(*,*)
stop
end if
! find the shortest lattice vector
j=1
t1=1.d8
do i=1,n
if (dp(i).lt.t1+epslat) then
j=i
t1=dp(i)
end if
end do
avec(:,1)=vp(:,j)
! find the next shortest lattice vector not parallel to the first
j=1
t1=1.d8
do i=1,n
call r3cross(avec(:,1),vp(:,i),v1)
t2=sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
if (t2.gt.epslat) then
if (dp(i).lt.t1+epslat) then
j=i
t1=dp(i)
end if
end if
end do
avec(:,2)=vp(:,j)
! find the next shortest lattice vector which gives non-zero unit cell volume
call r3cross(avec(:,1),avec(:,2),v1)
j=1
t1=1.d8
do i=1,n
t2=dot_product(vp(:,i),v1(:))
if (abs(t2).gt.epslat) then
if (dp(i).lt.t1+epslat) then
j=i
t1=dp(i)
end if
end if
end do
avec(:,3)=vp(:,j)
call r3minv(avec,ainv)
! remove redundant atoms
do is=1,nspecies
na=0
do ia=1,natoms(is)
call r3mv(ainv,atposc(:,ia,is),v1)
call r3frac(epslat,v1)
do ja=1,na
t1=sum(abs(atposl(:,ja,is)-v1(:)))
if (t1.lt.epslat) goto 30
end do
na=na+1
atposl(:,na,is)=v1(:)
call r3mv(avec,atposl(:,na,is),atposc(:,na,is))
bfcmt0(:,na,is)=bfcmt0(:,ia,is)
30 continue
end do
natoms(is)=na
end do
deallocate(dp,vp)
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/gencrystal.f90 0000644 0000000 0000000 00000000132 14061636515 017565 x ustar 00 30 mtime=1623670093.514103792
30 atime=1623670093.514103792
30 ctime=1623670093.514103792
elk-7.2.42/src/spacegroup/gencrystal.f90 0000644 0025044 0025044 00000005773 14061636515 021636 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine gencrystal
use modmain
implicit none
! local variables
integer is,ia,ip,i,j
integer i1,i2,i3
integer ngen,ngrp
real(8) abr,acr,bcr
real(8) sab,cab,cac,cbc
real(8) v1(3),v2(3),t1
! space group generator Seitz matrices
real(8) srgen(3,3,12),stgen(3,12)
! space group Seitz matrices
real(8) srgrp(3,3,192),stgrp(3,192)
! convert angles from degrees to radians
abr=ab*(pi/180.d0)
acr=ac*(pi/180.d0)
bcr=bc*(pi/180.d0)
! setup lattice vectors
sab=sin(abr)
if (abs(sab).lt.epslat) then
write(*,*)
write(*,'("Error(gencrystal): degenerate lattice vectors")')
write(*,*)
stop
end if
cab=cos(abr)
cac=cos(acr)
cbc=cos(bcr)
avec(1,1)=a
avec(2,1)=0.d0
avec(3,1)=0.d0
avec(1,2)=b*cab
avec(2,2)=b*sab
avec(3,2)=0.d0
avec(1,3)=c*cac
avec(2,3)=c*(cbc-cab*cac)/sab
avec(3,3)=c*sqrt(sab**2-cac**2+2.d0*cab*cac*cbc-cbc**2)/sab
do i=1,3
do j=1,3
if (abs(avec(i,j)).lt.epslat) avec(i,j)=0.d0
end do
end do
! scale lattice vectors by the number of unit cells
do i=1,3
avec(:,i)=avec(:,i)*dble(ncell(i))
end do
! determine the Hall symbol from the Hermann-Mauguin symbol
call sgsymb(hrmg,num,schn,hall)
! determine the space group generators
call seitzgen(hall,ngen,srgen,stgen)
! compute the space group operations
call gengroup(ngen,srgen,stgen,ngrp,srgrp,stgrp)
! compute the equivalent atomic positions
do is=1,nspecies
natoms(is)=0
do ip=1,nwpos(is)
do j=1,ngrp
! apply the space group operation
call r3mv(srgrp(:,1,j),wpos(:,ip,is),v1)
v1(:)=v1(:)+stgrp(:,j)
do i1=0,ncell(1)-1
do i2=0,ncell(2)-1
do i3=0,ncell(3)-1
v2(1)=(v1(1)+dble(i1))/dble(ncell(1))
v2(2)=(v1(2)+dble(i2))/dble(ncell(2))
v2(3)=(v1(3)+dble(i3))/dble(ncell(3))
call r3frac(epslat,v2)
! check if new position already exists
do ia=1,natoms(is)
t1=sum(abs(v2(:)-atposl(:,ia,is)))
if (t1.lt.epslat) goto 30
end do
! add new position to list
natoms(is)=natoms(is)+1
if (natoms(is).gt.maxatoms) then
write(*,*)
write(*,'("Error(gencrystal): natoms too large")')
write(*,'(" for species ",I4)') is
write(*,'("Adjust maxatoms and recompile code")')
write(*,*)
stop
end if
atposl(:,natoms(is),is)=v2(:)
end do
end do
end do
30 continue
end do
end do
natmtot=natmtot+natoms(is)
end do
! set magnetic fields to zero
bfcmt0(:,:,:)=0.d0
! reduce conventional cell to primitive cell if required
if (primcell) call findprimcell
! find the total number of atoms
natmtot=0
do is=1,nspecies
natmtot=natmtot+natoms(is)
end do
! determine the Cartesian atomic coordinates
do is=1,nspecies
do ia=1,natoms(is)
call r3mv(avec,atposl(:,ia,is),atposc(:,ia,is))
end do
end do
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/gengroup.f90 0000644 0000000 0000000 00000000130 14061636515 017236 x ustar 00 29 mtime=1623670093.51610379
30 atime=1623670093.515103791
29 ctime=1623670093.51610379
elk-7.2.42/src/spacegroup/gengroup.f90 0000644 0025044 0025044 00000003317 14061636515 021301 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine gengroup(ngen,srgen,stgen,ngrp,srgrp,stgrp)
implicit none
! arguments
integer, intent(in) :: ngen
real(8), intent(in) :: srgen(3,3,ngen)
real(8), intent(in) :: stgen(3,ngen)
integer, intent(out) :: ngrp
real(8), intent(out) :: srgrp(3,3,192)
real(8), intent(out) :: stgrp(3,192)
! local variables
integer i,j,k
real(8), parameter :: eps=1.d-6
real(8) sr(3,3),st(3)
! external functions
logical seitzeq
external seitzeq
! store the identity
ngrp=1
srgrp(1,1,1)=1.d0; srgrp(1,2,1)=0.d0; srgrp(1,3,1)=0.d0
srgrp(2,1,1)=0.d0; srgrp(2,2,1)=1.d0; srgrp(2,3,1)=0.d0
srgrp(3,1,1)=0.d0; srgrp(3,2,1)=0.d0; srgrp(3,3,1)=1.d0
stgrp(:,1)=0.d0
10 continue
! right multiply by the generators
do i=1,ngen
do j=1,ngrp
call seitzmul(eps,srgrp(:,:,j),stgrp(:,j),srgen(:,:,i),stgen(:,i),sr,st)
! check if the new element already exists
do k=1,ngrp
if (seitzeq(eps,srgrp(:,:,k),stgrp(:,k),sr,st)) goto 20
end do
goto 40
20 continue
end do
end do
! left multiply by the generators
do i=1,ngen
do j=1,ngrp
call seitzmul(eps,srgen(:,:,i),stgen(:,i),srgrp(:,:,j),stgrp(:,j),sr,st)
! check if the new element already exists
do k=1,ngrp
if (seitzeq(eps,srgrp(:,:,k),stgrp(:,k),sr,st)) goto 30
end do
goto 40
30 continue
end do
end do
! all elements accounted for
return
40 continue
! add new element
ngrp=ngrp+1
if (ngrp.gt.192) then
write(*,*)
write(*,'("Error(gengroup): more than 192 group elements")')
write(*,*)
stop
end if
srgrp(:,:,ngrp)=sr(:,:)
stgrp(:,ngrp)=st(:)
goto 10
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/geomplot.f90 0000644 0000000 0000000 00000000127 14061636515 017244 x ustar 00 29 mtime=1623670093.51710379
29 atime=1623670093.51710379
29 ctime=1623670093.51710379
elk-7.2.42/src/spacegroup/geomplot.f90 0000644 0025044 0025044 00000004453 14061636515 021303 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2007 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine geomplot
use modmain
implicit none
! local variables
integer is,ia
! Bohr to Angstroms (CODATA 2002)
real(8), parameter :: au_to_ang=0.5291772108d0
real(8) v1(3),v2(3),v3(3),v4(3),t1
real(8) dxx,dyx,dyy,dzx,dzy,dzz
!------------------------------------------------!
! write the XCrysden file to crystal.xsf !
!------------------------------------------------!
open(50,file='crystal.xsf',action='WRITE',form='FORMATTED')
write(50,*)
write(50,'("CRYSTAL")')
write(50,*)
write(50,'("PRIMVEC")')
write(50,'(3G18.10)') avec(:,1)*au_to_ang
write(50,'(3G18.10)') avec(:,2)*au_to_ang
write(50,'(3G18.10)') avec(:,3)*au_to_ang
write(50,*)
write(50,'("PRIMCOORD")')
write(50,'(2I8)') natmtot,1
do is=1,nspecies
do ia=1,natoms(is)
call r3mv(avec,atposl(:,ia,is),v1)
write(50,'(A,3G18.10)') trim(spsymb(is)),v1(:)*au_to_ang
end do
end do
close(50)
write(*,*)
write(*,'("Info(writexsf):")')
write(*,'(" XCrysDen file written to crystal.xsf")')
!-----------------------------------------------!
! write the V_Sim file to crystal.ascii !
!-----------------------------------------------!
! determine coordinate system vectors
t1=sqrt(avec(1,1)**2+avec(2,1)**2+avec(3,1)**2)
v1(:)=avec(:,1)/t1
t1=sqrt(avec(1,2)**2+avec(2,2)**2+avec(3,2)**2)
v2(:)=avec(:,2)/t1
call r3cross(v1,v2,v3)
t1=sqrt(v3(1)**2+v3(2)**2+v3(3)**2)
v3(:)=v3(:)/t1
call r3cross(v3,v1,v2)
t1=sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
v2(:)=v2(:)/t1
dxx=dot_product(avec(:,1),v1(:))
dyx=dot_product(avec(:,2),v1(:))
dyy=dot_product(avec(:,2),v2(:))
dzx=dot_product(avec(:,3),v1(:))
dzy=dot_product(avec(:,3),v2(:))
dzz=dot_product(avec(:,3),v3(:))
open(50,file='crystal.ascii',action='WRITE',form='FORMATTED')
write(50,*)
write(50,'(3G18.10)') dxx,dyx,dyy
write(50,'(3G18.10)') dzx,dzy,dzz
write(50,*)
do is=1,nspecies
do ia=1,natoms(is)
v4(1)=dot_product(atposc(:,ia,is),v1(:))
v4(2)=dot_product(atposc(:,ia,is),v2(:))
v4(3)=dot_product(atposc(:,ia,is),v3(:))
write(50,'(3G18.10," ",A)') v4,trim(spsymb(is))
end do
end do
close(50)
write(*,*)
write(*,'("Info(writevsim):")')
write(*,'(" V_Sim file written to crystal.ascii")')
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/main.f90 0000644 0000000 0000000 00000000132 14061636515 016336 x ustar 00 30 mtime=1623670093.519103788
30 atime=1623670093.518103789
30 ctime=1623670093.519103788
elk-7.2.42/src/spacegroup/main.f90 0000644 0025044 0025044 00000132676 14061636515 020412 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
program main
implicit none
! read the input parameters from spacegroup.in
call readinput
! generate the lattice and atomic basis
call gencrystal
! write the structural data to GEOMETRY.OUT
call writegeom
! write the XCrySDen and V_Sim files for plotting
call geomplot
stop
end program
!BOI
! !TITLE: {\huge{\sc The Spacegroup Manual}}\\ \Large{\sc Version 1.2.1}
! !AUTHORS: {\sc J. K. Dewhurst, S. Sharma and L. Nordstr\"{o}m}
! !AFFILIATION:
! !INTRODUCTION: Introduction
! Spacegroup is a utility which produces crystal geometry for use with the Elk
! code, from the space group defined by its Hermann-Mauguin symbol and lattice
! vector lengths and angles. Spacegroup recognises all 230 space groups in
! various coordinate settings giving a total of 530 possible symbols, which are
! tabulated below. The code also provides output compatible with the XCrysDen or
! V\_Sim packages for visualisation of the crystal structure.
! \section{Usage}
! Only one input file, {\tt spacegroup.in}, is required. The structure of this
! file is illustrated by the following example for the high $T_c$ superconductor
! La$_2$CuO$_4$:
! \begin{verbatim}
! 'Bmab' : hrmg
! 10.0605232 10.0605232 24.972729 : a, b, c
! 90.0 90.0 90.0 : bc, ac, ab
! 1 1 1 : ncell
! .true. : primcell
! 3 : nspecies
! 'La' : spsymb
! 1 : nwpos
! 0.0000 0.0000 0.3608 : wpos
! 'Cu'
! 1
! 0.0000 0.0000 0.0000
! 'O'
! 2
! 0.2500 0.2500 0.0000
! 0.0000 0.0000 0.1820
! \end{verbatim}
! The input parameters are defined as follows:
! \vskip 6pt
! {\tt hrmg}\\
! The Hermann-Mauguin symbol of a space group listed in the table below.
! (case-sensitive)
! \vskip 6pt
! {\tt a}, {\tt b}, {\tt c}\\
! Lattice vector lengths in Bohr (i.e. atomic units, {\bf NOT} \AA ngstroms).
! \vskip 6pt
! {\tt bc}, {\tt ac}, {\tt ab}\\
! Angles in degrees between lattice vectors ${\bf b}$ and ${\bf c}$ ($\alpha$);
! ${\bf a}$ and ${\bf c}$ ($\beta$); and ${\bf a}$ and ${\bf b}$ ($\gamma$).
! \vskip 6pt
! {\tt ncell}\\
! The number of unit cells required in each direction.
! \vskip 6pt
! {\tt primcell}\\
! Set to {\tt .true.} if the primitive unit cell should be found.
! \vskip 6pt
! {\tt nspecies}\\
! Number of atomic species.
! \vskip 6pt
! {\tt spsymb}\\
! The atomic species symbol.
! \vskip 6pt
! {\tt nwpos}\\
! The number of Wyckoff positional coordinates.
! \vskip 6pt
! {\tt wpos}\\
! Wyckoff positional coordinates in fractions of the lattice vectors.
! \vskip 6pt
! Note that {\tt nwpos} and {\tt wpos} are repeated as many times as there are
! species. After creating the input file, the {\tt spacegroup} command is run
! and the files {\tt GEOMETRY.OUT} and {\tt crystal.xsf} should be produced.
! The {\tt GEOMETRY.OUT} file can simply be appended to an {\tt elk.in} file. If
! XCrysDen is available, then use the command
! \vskip 6pt
! \hskip 24pt {\tt xcrysden --xsf crystal.xsf}
! \vskip 6pt
! to render the unit cell.
! \section{Table of space group symbols}
! We acknowledge Ralf W. Grosse-Kunstleve ({\tt http://cci.lbl.gov/sginfo/})
! for the following table which associates space group numbers, Sch\"{o}nflies
! symbols, Hermann-Mauguin symbols, and Hall symbols.
! \newpage
! \begin{center}
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 1 & C$_{1}^{1}$ & P1 & P 1 \\
! 2 & C$_{i}^{1}$ & P-1 & -P 1 \\
! 3:b & C$_{2}^{1}$ & P2:b = P121 & P 2y \\
! 3:c & C$_{2}^{1}$ & P2:c = P112 & P 2 \\
! 3:a & C$_{2}^{1}$ & P2:a = P211 & P 2x \\
! 4:b & C$_{2}^{2}$ & P21:b = P1211 & P 2yb \\
! 4:c & C$_{2}^{2}$ & P21:c = P1121 & P 2c \\
! 4:a & C$_{2}^{2}$ & P21:a = P2111 & P 2xa \\
! 5:b1 & C$_{2}^{3}$ & C2:b1 = C121 & C 2y \\
! 5:b2 & C$_{2}^{3}$ & C2:b2 = A121 & A 2y \\
! 5:b3 & C$_{2}^{3}$ & C2:b3 = I121 & I 2y \\
! 5:c1 & C$_{2}^{3}$ & C2:c1 = A112 & A 2 \\
! 5:c2 & C$_{2}^{3}$ & C2:c2 = B112 = B2 & B 2 \\
! 5:c3 & C$_{2}^{3}$ & C2:c3 = I112 & I 2 \\
! 5:a1 & C$_{2}^{3}$ & C2:a1 = B211 & B 2x \\
! 5:a2 & C$_{2}^{3}$ & C2:a2 = C211 & C 2x \\
! 5:a3 & C$_{2}^{3}$ & C2:a3 = I211 & I 2x \\
! 6:b & C$_{s}^{1}$ & Pm:b = P1m1 & P -2y \\
! 6:c & C$_{s}^{1}$ & Pm:c = P11m & P -2 \\
! 6:a & C$_{s}^{1}$ & Pm:a = Pm11 & P -2x \\
! 7:b1 & C$_{s}^{2}$ & Pc:b1 = P1c1 & P -2yc \\
! 7:b2 & C$_{s}^{2}$ & Pc:b2 = P1n1 & P -2yac \\
! 7:b3 & C$_{s}^{2}$ & Pc:b3 = P1a1 & P -2ya \\
! 7:c1 & C$_{s}^{2}$ & Pc:c1 = P11a & P -2a \\
! 7:c2 & C$_{s}^{2}$ & Pc:c2 = P11n & P -2ab \\
! 7:c3 & C$_{s}^{2}$ & Pc:c3 = P11b = Pb & P -2b \\
! 7:a1 & C$_{s}^{2}$ & Pc:a1 = Pb11 & P -2xb \\
! 7:a2 & C$_{s}^{2}$ & Pc:a2 = Pn11 & P -2xbc \\
! 7:a3 & C$_{s}^{2}$ & Pc:a3 = Pc11 & P -2xc \\
! 8:b1 & C$_{s}^{3}$ & Cm:b1 = C1m1 & C -2y \\
! 8:b2 & C$_{s}^{3}$ & Cm:b2 = A1m1 & A -2y \\
! 8:b3 & C$_{s}^{3}$ & Cm:b3 = I1m1 & I -2y \\
! 8:c1 & C$_{s}^{3}$ & Cm:c1 = A11m & A -2 \\
! 8:c2 & C$_{s}^{3}$ & Cm:c2 = B11m = Bm & B -2 \\
! 8:c3 & C$_{s}^{3}$ & Cm:c3 = I11m & I -2 \\
! 8:a1 & C$_{s}^{3}$ & Cm:a1 = Bm11 & B -2x \\
! 8:a2 & C$_{s}^{3}$ & Cm:a2 = Cm11 & C -2x \\
! 8:a3 & C$_{s}^{3}$ & Cm:a3 = Im11 & I -2x \\
! 9:b1 & C$_{s}^{4}$ & Cc:b1 = C1c1 & C -2yc \\
! 9:b2 & C$_{s}^{4}$ & Cc:b2 = A1n1 & A -2yac \\
! 9:b3 & C$_{s}^{4}$ & Cc:b3 = I1a1 & I -2ya \\
! 9:-b1 & C$_{s}^{4}$ & Cc:-b1 = A1a1 & A -2ya \\
! 9:-b2 & C$_{s}^{4}$ & Cc:-b2 = C1n1 & C -2ybc \\
! 9:-b3 & C$_{s}^{4}$ & Cc:-b3 = I1c1 & I -2yc \\
! 9:c1 & C$_{s}^{4}$ & Cc:c1 = A11a & A -2a \\
! 9:c2 & C$_{s}^{4}$ & Cc:c2 = B11n & B -2bc \\
! 9:c3 & C$_{s}^{4}$ & Cc:c3 = I11b & I -2b \\
! 9:-c1 & C$_{s}^{4}$ & Cc:-c1 = B11b = Bb & B -2b \\
! 9:-c2 & C$_{s}^{4}$ & Cc:-c2 = A11n & A -2ac \\
! 9:-c3 & C$_{s}^{4}$ & Cc:-c3 = I11a & I -2a \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 9:a1 & C$_{s}^{4}$ & Cc:a1 = Bb11 & B -2xb \\
! 9:a2 & C$_{s}^{4}$ & Cc:a2 = Cn11 & C -2xbc \\
! 9:a3 & C$_{s}^{4}$ & Cc:a3 = Ic11 & I -2xc \\
! 9:-a1 & C$_{s}^{4}$ & Cc:-a1 = Cc11 & C -2xc \\
! 9:-a2 & C$_{s}^{4}$ & Cc:-a2 = Bn11 & B -2xbc \\
! 9:-a3 & C$_{s}^{4}$ & Cc:-a3 = Ib11 & I -2xb \\
! 10:b & C$_{2h}^{1}$ & P2/m:b = P12/m1 & -P 2y \\
! 10:c & C$_{2h}^{1}$ & P2/m:c = P112/m & -P 2 \\
! 10:a & C$_{2h}^{1}$ & P2/m:a = P2/m11 & -P 2x \\
! 11:b & C$_{2h}^{2}$ & P21/m:b = P121/m1 & -P 2yb \\
! 11:c & C$_{2h}^{2}$ & P21/m:c = P1121/m & -P 2c \\
! 11:a & C$_{2h}^{2}$ & P21/m:a = P21/m11 & -P 2xa \\
! 12:b1 & C$_{2h}^{3}$ & C2/m:b1 = C12/m1 & -C 2y \\
! 12:b2 & C$_{2h}^{3}$ & C2/m:b2 = A12/m1 & -A 2y \\
! 12:b3 & C$_{2h}^{3}$ & C2/m:b3 = I12/m1 & -I 2y \\
! 12:c1 & C$_{2h}^{3}$ & C2/m:c1 = A112/m & -A 2 \\
! 12:c2 & C$_{2h}^{3}$ & C2/m:c2 = B112/m = B2/m & -B 2 \\
! 12:c3 & C$_{2h}^{3}$ & C2/m:c3 = I112/m & -I 2 \\
! 12:a1 & C$_{2h}^{3}$ & C2/m:a1 = B2/m11 & -B 2x \\
! 12:a2 & C$_{2h}^{3}$ & C2/m:a2 = C2/m11 & -C 2x \\
! 12:a3 & C$_{2h}^{3}$ & C2/m:a3 = I2/m11 & -I 2x \\
! 13:b1 & C$_{2h}^{4}$ & P2/c:b1 = P12/c1 & -P 2yc \\
! 13:b2 & C$_{2h}^{4}$ & P2/c:b2 = P12/n1 & -P 2yac \\
! 13:b3 & C$_{2h}^{4}$ & P2/c:b3 = P12/a1 & -P 2ya \\
! 13:c1 & C$_{2h}^{4}$ & P2/c:c1 = P112/a & -P 2a \\
! 13:c2 & C$_{2h}^{4}$ & P2/c:c2 = P112/n & -P 2ab \\
! 13:c3 & C$_{2h}^{4}$ & P2/c:c3 = P112/b = P2/b & -P 2b \\
! 13:a1 & C$_{2h}^{4}$ & P2/c:a1 = P2/b11 & -P 2xb \\
! 13:a2 & C$_{2h}^{4}$ & P2/c:a2 = P2/n11 & -P 2xbc \\
! 13:a3 & C$_{2h}^{4}$ & P2/c:a3 = P2/c11 & -P 2xc \\
! 14:b1 & C$_{2h}^{5}$ & P21/c:b1 = P121/c1 & -P 2ybc \\
! 14:b2 & C$_{2h}^{5}$ & P21/c:b2 = P121/n1 & -P 2yn \\
! 14:b3 & C$_{2h}^{5}$ & P21/c:b3 = P121/a1 & -P 2yab \\
! 14:c1 & C$_{2h}^{5}$ & P21/c:c1 = P1121/a & -P 2ac \\
! 14:c2 & C$_{2h}^{5}$ & P21/c:c2 = P1121/n & -P 2n \\
! 14:c3 & C$_{2h}^{5}$ & P21/c:c3 = P1121/b = P21/b & -P 2bc \\
! 14:a1 & C$_{2h}^{5}$ & P21/c:a1 = P21/b11 & -P 2xab \\
! 14:a2 & C$_{2h}^{5}$ & P21/c:a2 = P21/n11 & -P 2xn \\
! 14:a3 & C$_{2h}^{5}$ & P21/c:a3 = P21/c11 & -P 2xac \\
! 15:b1 & C$_{2h}^{6}$ & C2/c:b1 = C12/c1 & -C 2yc \\
! 15:b2 & C$_{2h}^{6}$ & C2/c:b2 = A12/n1 & -A 2yac \\
! 15:b3 & C$_{2h}^{6}$ & C2/c:b3 = I12/a1 & -I 2ya \\
! 15:-b1 & C$_{2h}^{6}$ & C2/c:-b1 = A12/a1 & -A 2ya \\
! 15:-b2 & C$_{2h}^{6}$ & C2/c:-b2 = C12/n1 & -C 2ybc \\
! 15:-b3 & C$_{2h}^{6}$ & C2/c:-b3 = I12/c1 & -I 2yc \\
! 15:c1 & C$_{2h}^{6}$ & C2/c:c1 = A112/a & -A 2a \\
! 15:c2 & C$_{2h}^{6}$ & C2/c:c2 = B112/n & -B 2bc \\
! 15:c3 & C$_{2h}^{6}$ & C2/c:c3 = I112/b & -I 2b \\
! 15:-c1 & C$_{2h}^{6}$ & C2/c:-c1 = B112/b = B2/b & -B 2b \\
! 15:-c2 & C$_{2h}^{6}$ & C2/c:-c2 = A112/n & -A 2ac \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 15:-c3 & C$_{2h}^{6}$ & C2/c:-c3 = I112/a & -I 2a \\
! 15:a1 & C$_{2h}^{6}$ & C2/c:a1 = B2/b11 & -B 2xb \\
! 15:a2 & C$_{2h}^{6}$ & C2/c:a2 = C2/n11 & -C 2xbc \\
! 15:a3 & C$_{2h}^{6}$ & C2/c:a3 = I2/c11 & -I 2xc \\
! 15:-a1 & C$_{2h}^{6}$ & C2/c:-a1 = C2/c11 & -C 2xc \\
! 15:-a2 & C$_{2h}^{6}$ & C2/c:-a2 = B2/n11 & -B 2xbc \\
! 15:-a3 & C$_{2h}^{6}$ & C2/c:-a3 = I2/b11 & -I 2xb \\
! 16 & D$_{2}^{1}$ & P222 & P 2 2 \\
! 17 & D$_{2}^{2}$ & P2221 & P 2c 2 \\
! 17:cab & D$_{2}^{2}$ & P2122 & P 2a 2a \\
! 17:bca & D$_{2}^{2}$ & P2212 & P 2 2b \\
! 18 & D$_{2}^{3}$ & P21212 & P 2 2ab \\
! 18:cab & D$_{2}^{3}$ & P22121 & P 2bc 2 \\
! 18:bca & D$_{2}^{3}$ & P21221 & P 2ac 2ac \\
! 19 & D$_{2}^{4}$ & P212121 & P 2ac 2ab \\
! 20 & D$_{2}^{5}$ & C2221 & C 2c 2 \\
! 20:cab & D$_{2}^{5}$ & A2122 & A 2a 2a \\
! 20:bca & D$_{2}^{5}$ & B2212 & B 2 2b \\
! 21 & D$_{2}^{6}$ & C222 & C 2 2 \\
! 21:cab & D$_{2}^{6}$ & A222 & A 2 2 \\
! 21:bca & D$_{2}^{6}$ & B222 & B 2 2 \\
! 22 & D$_{2}^{7}$ & F222 & F 2 2 \\
! 23 & D$_{2}^{8}$ & I222 & I 2 2 \\
! 24 & D$_{2}^{9}$ & I212121 & I 2b 2c \\
! 25 & C$_{2v}^{1}$ & Pmm2 & P 2 -2 \\
! 25:cab & C$_{2v}^{1}$ & P2mm & P -2 2 \\
! 25:bca & C$_{2v}^{1}$ & Pm2m & P -2 -2 \\
! 26 & C$_{2v}^{2}$ & Pmc21 & P 2c -2 \\
! 26:ba-c & C$_{2v}^{2}$ & Pcm21 & P 2c -2c \\
! 26:cab & C$_{2v}^{2}$ & P21ma & P -2a 2a \\
! 26:-cba & C$_{2v}^{2}$ & P21am & P -2 2a \\
! 26:bca & C$_{2v}^{2}$ & Pb21m & P -2 -2b \\
! 26:a-cb & C$_{2v}^{2}$ & Pm21b & P -2b -2 \\
! 27 & C$_{2v}^{3}$ & Pcc2 & P 2 -2c \\
! 27:cab & C$_{2v}^{3}$ & P2aa & P -2a 2 \\
! 27:bca & C$_{2v}^{3}$ & Pb2b & P -2b -2b \\
! 28 & C$_{2v}^{4}$ & Pma2 & P 2 -2a \\
! 28:ba-c & C$_{2v}^{4}$ & Pbm2 & P 2 -2b \\
! 28:cab & C$_{2v}^{4}$ & P2mb & P -2b 2 \\
! 28:-cba & C$_{2v}^{4}$ & P2cm & P -2c 2 \\
! 28:bca & C$_{2v}^{4}$ & Pc2m & P -2c -2c \\
! 28:a-cb & C$_{2v}^{4}$ & Pm2a & P -2a -2a \\
! 29 & C$_{2v}^{5}$ & Pca21 & P 2c -2ac \\
! 29:ba-c & C$_{2v}^{5}$ & Pbc21 & P 2c -2b \\
! 29:cab & C$_{2v}^{5}$ & P21ab & P -2b 2a \\
! 29:-cba & C$_{2v}^{5}$ & P21ca & P -2ac 2a \\
! 29:bca & C$_{2v}^{5}$ & Pc21b & P -2bc -2c \\
! 29:a-cb & C$_{2v}^{5}$ & Pb21a & P -2a -2ab \\
! 30 & C$_{2v}^{6}$ & Pnc2 & P 2 -2bc \\
! 30:ba-c & C$_{2v}^{6}$ & Pcn2 & P 2 -2ac \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 30:cab & C$_{2v}^{6}$ & P2na & P -2ac 2 \\
! 30:-cba & C$_{2v}^{6}$ & P2an & P -2ab 2 \\
! 30:bca & C$_{2v}^{6}$ & Pb2n & P -2ab -2ab \\
! 30:a-cb & C$_{2v}^{6}$ & Pn2b & P -2bc -2bc \\
! 31 & C$_{2v}^{7}$ & Pmn21 & P 2ac -2 \\
! 31:ba-c & C$_{2v}^{7}$ & Pnm21 & P 2bc -2bc \\
! 31:cab & C$_{2v}^{7}$ & P21mn & P -2ab 2ab \\
! 31:-cba & C$_{2v}^{7}$ & P21nm & P -2 2ac \\
! 31:bca & C$_{2v}^{7}$ & Pn21m & P -2 -2bc \\
! 31:a-cb & C$_{2v}^{7}$ & Pm21n & P -2ab -2 \\
! 32 & C$_{2v}^{8}$ & Pba2 & P 2 -2ab \\
! 32:cab & C$_{2v}^{8}$ & P2cb & P -2bc 2 \\
! 32:bca & C$_{2v}^{8}$ & Pc2a & P -2ac -2ac \\
! 33 & C$_{2v}^{9}$ & Pna21 & P 2c -2n \\
! 33:ba-c & C$_{2v}^{9}$ & Pbn21 & P 2c -2ab \\
! 33:cab & C$_{2v}^{9}$ & P21nb & P -2bc 2a \\
! 33:-cba & C$_{2v}^{9}$ & P21cn & P -2n 2a \\
! 33:bca & C$_{2v}^{9}$ & Pc21n & P -2n -2ac \\
! 33:a-cb & C$_{2v}^{9}$ & Pn21a & P -2ac -2n \\
! 34 & C$_{2v}^{10}$ & Pnn2 & P 2 -2n \\
! 34:cab & C$_{2v}^{10}$ & P2nn & P -2n 2 \\
! 34:bca & C$_{2v}^{10}$ & Pn2n & P -2n -2n \\
! 35 & C$_{2v}^{11}$ & Cmm2 & C 2 -2 \\
! 35:cab & C$_{2v}^{11}$ & A2mm & A -2 2 \\
! 35:bca & C$_{2v}^{11}$ & Bm2m & B -2 -2 \\
! 36 & C$_{2v}^{12}$ & Cmc21 & C 2c -2 \\
! 36:ba-c & C$_{2v}^{12}$ & Ccm21 & C 2c -2c \\
! 36:cab & C$_{2v}^{12}$ & A21ma & A -2a 2a \\
! 36:-cba & C$_{2v}^{12}$ & A21am & A -2 2a \\
! 36:bca & C$_{2v}^{12}$ & Bb21m & B -2 -2b \\
! 36:a-cb & C$_{2v}^{12}$ & Bm21b & B -2b -2 \\
! 37 & C$_{2v}^{13}$ & Ccc2 & C 2 -2c \\
! 37:cab & C$_{2v}^{13}$ & A2aa & A -2a 2 \\
! 37:bca & C$_{2v}^{13}$ & Bb2b & B -2b -2b \\
! 38 & C$_{2v}^{14}$ & Amm2 & A 2 -2 \\
! 38:ba-c & C$_{2v}^{14}$ & Bmm2 & B 2 -2 \\
! 38:cab & C$_{2v}^{14}$ & B2mm & B -2 2 \\
! 38:-cba & C$_{2v}^{14}$ & C2mm & C -2 2 \\
! 38:bca & C$_{2v}^{14}$ & Cm2m & C -2 -2 \\
! 38:a-cb & C$_{2v}^{14}$ & Am2m & A -2 -2 \\
! 39 & C$_{2v}^{15}$ & Abm2 & A 2 -2c \\
! 39:ba-c & C$_{2v}^{15}$ & Bma2 & B 2 -2c \\
! 39:cab & C$_{2v}^{15}$ & B2cm & B -2c 2 \\
! 39:-cba & C$_{2v}^{15}$ & C2mb & C -2b 2 \\
! 39:bca & C$_{2v}^{15}$ & Cm2a & C -2b -2b \\
! 39:a-cb & C$_{2v}^{15}$ & Ac2m & A -2c -2c \\
! 40 & C$_{2v}^{16}$ & Ama2 & A 2 -2a \\
! 40:ba-c & C$_{2v}^{16}$ & Bbm2 & B 2 -2b \\
! 40:cab & C$_{2v}^{16}$ & B2mb & B -2b 2 \\
! 40:-cba & C$_{2v}^{16}$ & C2cm & C -2c 2 \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 40:bca & C$_{2v}^{16}$ & Cc2m & C -2c -2c \\
! 40:a-cb & C$_{2v}^{16}$ & Am2a & A -2a -2a \\
! 41 & C$_{2v}^{17}$ & Aba2 & A 2 -2ac \\
! 41:ba-c & C$_{2v}^{17}$ & Bba2 & B 2 -2bc \\
! 41:cab & C$_{2v}^{17}$ & B2cb & B -2bc 2 \\
! 41:-cba & C$_{2v}^{17}$ & C2cb & C -2bc 2 \\
! 41:bca & C$_{2v}^{17}$ & Cc2a & C -2bc -2bc \\
! 41:a-cb & C$_{2v}^{17}$ & Ac2a & A -2ac -2ac \\
! 42 & C$_{2v}^{18}$ & Fmm2 & F 2 -2 \\
! 42:cab & C$_{2v}^{18}$ & F2mm & F -2 2 \\
! 42:bca & C$_{2v}^{18}$ & Fm2m & F -2 -2 \\
! 43 & C$_{2v}^{19}$ & Fdd2 & F 2 -2d \\
! 43:cab & C$_{2v}^{19}$ & F2dd & F -2d 2 \\
! 43:bca & C$_{2v}^{19}$ & Fd2d & F -2d -2d \\
! 44 & C$_{2v}^{20}$ & Imm2 & I 2 -2 \\
! 44:cab & C$_{2v}^{20}$ & I2mm & I -2 2 \\
! 44:bca & C$_{2v}^{20}$ & Im2m & I -2 -2 \\
! 45 & C$_{2v}^{21}$ & Iba2 & I 2 -2c \\
! 45:cab & C$_{2v}^{21}$ & I2cb & I -2a 2 \\
! 45:bca & C$_{2v}^{21}$ & Ic2a & I -2b -2b \\
! 46 & C$_{2v}^{22}$ & Ima2 & I 2 -2a \\
! 46:ba-c & C$_{2v}^{22}$ & Ibm2 & I 2 -2b \\
! 46:cab & C$_{2v}^{22}$ & I2mb & I -2b 2 \\
! 46:-cba & C$_{2v}^{22}$ & I2cm & I -2c 2 \\
! 46:bca & C$_{2v}^{22}$ & Ic2m & I -2c -2c \\
! 46:a-cb & C$_{2v}^{22}$ & Im2a & I -2a -2a \\
! 47 & D$_{2h}^{1}$ & Pmmm & -P 2 2 \\
! 48:1 & D$_{2h}^{2}$ & Pnnn:1 & P 2 2 -1n \\
! 48:2 & D$_{2h}^{2}$ & Pnnn:2 & -P 2ab 2bc \\
! 49 & D$_{2h}^{3}$ & Pccm & -P 2 2c \\
! 49:cab & D$_{2h}^{3}$ & Pmaa & -P 2a 2 \\
! 49:bca & D$_{2h}^{3}$ & Pbmb & -P 2b 2b \\
! 50:1 & D$_{2h}^{4}$ & Pban:1 & P 2 2 -1ab \\
! 50:2 & D$_{2h}^{4}$ & Pban:2 & -P 2ab 2b \\
! 50:1cab & D$_{2h}^{4}$ & Pncb:1 & P 2 2 -1bc \\
! 50:2cab & D$_{2h}^{4}$ & Pncb:2 & -P 2b 2bc \\
! 50:1bca & D$_{2h}^{4}$ & Pcna:1 & P 2 2 -1ac \\
! 50:2bca & D$_{2h}^{4}$ & Pcna:2 & -P 2a 2c \\
! 51 & D$_{2h}^{5}$ & Pmma & -P 2a 2a \\
! 51:ba-c & D$_{2h}^{5}$ & Pmmb & -P 2b 2 \\
! 51:cab & D$_{2h}^{5}$ & Pbmm & -P 2 2b \\
! 51:-cba & D$_{2h}^{5}$ & Pcmm & -P 2c 2c \\
! 51:bca & D$_{2h}^{5}$ & Pmcm & -P 2c 2 \\
! 51:a-cb & D$_{2h}^{5}$ & Pmam & -P 2 2a \\
! 52 & D$_{2h}^{6}$ & Pnna & -P 2a 2bc \\
! 52:ba-c & D$_{2h}^{6}$ & Pnnb & -P 2b 2n \\
! 52:cab & D$_{2h}^{6}$ & Pbnn & -P 2n 2b \\
! 52:-cba & D$_{2h}^{6}$ & Pcnn & -P 2ab 2c \\
! 52:bca & D$_{2h}^{6}$ & Pncn & -P 2ab 2n \\
! 52:a-cb & D$_{2h}^{6}$ & Pnan & -P 2n 2bc \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 53 & D$_{2h}^{7}$ & Pmna & -P 2ac 2 \\
! 53:ba-c & D$_{2h}^{7}$ & Pnmb & -P 2bc 2bc \\
! 53:cab & D$_{2h}^{7}$ & Pbmn & -P 2ab 2ab \\
! 53:-cba & D$_{2h}^{7}$ & Pcnm & -P 2 2ac \\
! 53:bca & D$_{2h}^{7}$ & Pncm & -P 2 2bc \\
! 53:a-cb & D$_{2h}^{7}$ & Pman & -P 2ab 2 \\
! 54 & D$_{2h}^{8}$ & Pcca & -P 2a 2ac \\
! 54:ba-c & D$_{2h}^{8}$ & Pccb & -P 2b 2c \\
! 54:cab & D$_{2h}^{8}$ & Pbaa & -P 2a 2b \\
! 54:-cba & D$_{2h}^{8}$ & Pcaa & -P 2ac 2c \\
! 54:bca & D$_{2h}^{8}$ & Pbcb & -P 2bc 2b \\
! 54:a-cb & D$_{2h}^{8}$ & Pbab & -P 2b 2ab \\
! 55 & D$_{2h}^{9}$ & Pbam & -P 2 2ab \\
! 55:cab & D$_{2h}^{9}$ & Pmcb & -P 2bc 2 \\
! 55:bca & D$_{2h}^{9}$ & Pcma & -P 2ac 2ac \\
! 56 & D$_{2h}^{10}$ & Pccn & -P 2ab 2ac \\
! 56:cab & D$_{2h}^{10}$ & Pnaa & -P 2ac 2bc \\
! 56:bca & D$_{2h}^{10}$ & Pbnb & -P 2bc 2ab \\
! 57 & D$_{2h}^{11}$ & Pbcm & -P 2c 2b \\
! 57:ba-c & D$_{2h}^{11}$ & Pcam & -P 2c 2ac \\
! 57:cab & D$_{2h}^{11}$ & Pmca & -P 2ac 2a \\
! 57:-cba & D$_{2h}^{11}$ & Pmab & -P 2b 2a \\
! 57:bca & D$_{2h}^{11}$ & Pbma & -P 2a 2ab \\
! 57:a-cb & D$_{2h}^{11}$ & Pcmb & -P 2bc 2c \\
! 58 & D$_{2h}^{12}$ & Pnnm & -P 2 2n \\
! 58:cab & D$_{2h}^{12}$ & Pmnn & -P 2n 2 \\
! 58:bca & D$_{2h}^{12}$ & Pnmn & -P 2n 2n \\
! 59:1 & D$_{2h}^{13}$ & Pmmn:1 & P 2 2ab -1ab \\
! 59:2 & D$_{2h}^{13}$ & Pmmn:2 & -P 2ab 2a \\
! 59:1cab & D$_{2h}^{13}$ & Pnmm:1 & P 2bc 2 -1bc \\
! 59:2cab & D$_{2h}^{13}$ & Pnmm:2 & -P 2c 2bc \\
! 59:1bca & D$_{2h}^{13}$ & Pmnm:1 & P 2ac 2ac -1ac \\
! 59:2bca & D$_{2h}^{13}$ & Pmnm:2 & -P 2c 2a \\
! 60 & D$_{2h}^{14}$ & Pbcn & -P 2n 2ab \\
! 60:ba-c & D$_{2h}^{14}$ & Pcan & -P 2n 2c \\
! 60:cab & D$_{2h}^{14}$ & Pnca & -P 2a 2n \\
! 60:-cba & D$_{2h}^{14}$ & Pnab & -P 2bc 2n \\
! 60:bca & D$_{2h}^{14}$ & Pbna & -P 2ac 2b \\
! 60:a-cb & D$_{2h}^{14}$ & Pcnb & -P 2b 2ac \\
! 61 & D$_{2h}^{15}$ & Pbca & -P 2ac 2ab \\
! 61:ba-c & D$_{2h}^{15}$ & Pcab & -P 2bc 2ac \\
! 62 & D$_{2h}^{16}$ & Pnma & -P 2ac 2n \\
! 62:ba-c & D$_{2h}^{16}$ & Pmnb & -P 2bc 2a \\
! 62:cab & D$_{2h}^{16}$ & Pbnm & -P 2c 2ab \\
! 62:-cba & D$_{2h}^{16}$ & Pcmn & -P 2n 2ac \\
! 62:bca & D$_{2h}^{16}$ & Pmcn & -P 2n 2a \\
! 62:a-cb & D$_{2h}^{16}$ & Pnam & -P 2c 2n \\
! 63 & D$_{2h}^{17}$ & Cmcm & -C 2c 2 \\
! 63:ba-c & D$_{2h}^{17}$ & Ccmm & -C 2c 2c \\
! 63:cab & D$_{2h}^{17}$ & Amma & -A 2a 2a \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 63:-cba & D$_{2h}^{17}$ & Amam & -A 2 2a \\
! 63:bca & D$_{2h}^{17}$ & Bbmm & -B 2 2b \\
! 63:a-cb & D$_{2h}^{17}$ & Bmmb & -B 2b 2 \\
! 64 & D$_{2h}^{18}$ & Cmca & -C 2bc 2 \\
! 64:ba-c & D$_{2h}^{18}$ & Ccmb & -C 2bc 2bc \\
! 64:cab & D$_{2h}^{18}$ & Abma & -A 2ac 2ac \\
! 64:-cba & D$_{2h}^{18}$ & Acam & -A 2 2ac \\
! 64:bca & D$_{2h}^{18}$ & Bbcm & -B 2 2bc \\
! 64:a-cb & D$_{2h}^{18}$ & Bmab & -B 2bc 2 \\
! 65 & D$_{2h}^{19}$ & Cmmm & -C 2 2 \\
! 65:cab & D$_{2h}^{19}$ & Ammm & -A 2 2 \\
! 65:bca & D$_{2h}^{19}$ & Bmmm & -B 2 2 \\
! 66 & D$_{2h}^{20}$ & Cccm & -C 2 2c \\
! 66:cab & D$_{2h}^{20}$ & Amaa & -A 2a 2 \\
! 66:bca & D$_{2h}^{20}$ & Bbmb & -B 2b 2b \\
! 67 & D$_{2h}^{21}$ & Cmma & -C 2b 2 \\
! 67:ba-c & D$_{2h}^{21}$ & Cmmb & -C 2b 2b \\
! 67:cab & D$_{2h}^{21}$ & Abmm & -A 2c 2c \\
! 67:-cba & D$_{2h}^{21}$ & Acmm & -A 2 2c \\
! 67:bca & D$_{2h}^{21}$ & Bmcm & -B 2 2c \\
! 67:a-cb & D$_{2h}^{21}$ & Bmam & -B 2c 2 \\
! 68:1 & D$_{2h}^{22}$ & Ccca:1 & C 2 2 -1bc \\
! 68:2 & D$_{2h}^{22}$ & Ccca:2 & -C 2b 2bc \\
! 68:1ba-c & D$_{2h}^{22}$ & Cccb:1 & C 2 2 -1bc \\
! 68:2ba-c & D$_{2h}^{22}$ & Cccb:2 & -C 2b 2c \\
! 68:1cab & D$_{2h}^{22}$ & Abaa:1 & A 2 2 -1ac \\
! 68:2cab & D$_{2h}^{22}$ & Abaa:2 & -A 2a 2c \\
! 68:1-cba & D$_{2h}^{22}$ & Acaa:1 & A 2 2 -1ac \\
! 68:2-cba & D$_{2h}^{22}$ & Acaa:2 & -A 2ac 2c \\
! 68:1bca & D$_{2h}^{22}$ & Bbcb:1 & B 2 2 -1bc \\
! 68:2bca & D$_{2h}^{22}$ & Bbcb:2 & -B 2bc 2b \\
! 68:1a-cb & D$_{2h}^{22}$ & Bbab:1 & B 2 2 -1bc \\
! 68:2a-cb & D$_{2h}^{22}$ & Bbab:2 & -B 2b 2bc \\
! 69 & D$_{2h}^{23}$ & Fmmm & -F 2 2 \\
! 70:1 & D$_{2h}^{24}$ & Fddd:1 & F 2 2 -1d \\
! 70:2 & D$_{2h}^{24}$ & Fddd:2 & -F 2uv 2vw \\
! 71 & D$_{2h}^{25}$ & Immm & -I 2 2 \\
! 72 & D$_{2h}^{26}$ & Ibam & -I 2 2c \\
! 72:cab & D$_{2h}^{26}$ & Imcb & -I 2a 2 \\
! 72:bca & D$_{2h}^{26}$ & Icma & -I 2b 2b \\
! 73 & D$_{2h}^{27}$ & Ibca & -I 2b 2c \\
! 73:ba-c & D$_{2h}^{27}$ & Icab & -I 2a 2b \\
! 74 & D$_{2h}^{28}$ & Imma & -I 2b 2 \\
! 74:ba-c & D$_{2h}^{28}$ & Immb & -I 2a 2a \\
! 74:cab & D$_{2h}^{28}$ & Ibmm & -I 2c 2c \\
! 74:-cba & D$_{2h}^{28}$ & Icmm & -I 2 2b \\
! 74:bca & D$_{2h}^{28}$ & Imcm & -I 2 2a \\
! 74:a-cb & D$_{2h}^{28}$ & Imam & -I 2c 2 \\
! 75 & C$_{4}^{1}$ & P4 & P 4 \\
! 76 & C$_{4}^{2}$ & P41 & P 4w \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 77 & C$_{4}^{3}$ & P42 & P 4c \\
! 78 & C$_{4}^{4}$ & P43 & P 4cw \\
! 79 & C$_{4}^{5}$ & I4 & I 4 \\
! 80 & C$_{4}^{6}$ & I41 & I 4bw \\
! 81 & S$_{4}^{1}$ & P-4 & P -4 \\
! 82 & S$_{4}^{2}$ & I-4 & I -4 \\
! 83 & C$_{4h}^{1}$ & P4/m & -P 4 \\
! 84 & C$_{4h}^{2}$ & P42/m & -P 4c \\
! 85:1 & C$_{4h}^{3}$ & P4/n:1 & P 4ab -1ab \\
! 85:2 & C$_{4h}^{3}$ & P4/n:2 & -P 4a \\
! 86:1 & C$_{4h}^{4}$ & P42/n:1 & P 4n -1n \\
! 86:2 & C$_{4h}^{4}$ & P42/n:2 & -P 4bc \\
! 87 & C$_{4h}^{5}$ & I4/m & -I 4 \\
! 88:1 & C$_{4h}^{6}$ & I41/a:1 & I 4bw -1bw \\
! 88:2 & C$_{4h}^{6}$ & I41/a:2 & -I 4ad \\
! 89 & D$_{4}^{1}$ & P422 & P 4 2 \\
! 90 & D$_{4}^{2}$ & P4212 & P 4ab 2ab \\
! 91 & D$_{4}^{3}$ & P4122 & P 4w 2c \\
! 92 & D$_{4}^{4}$ & P41212 & P 4abw 2nw \\
! 93 & D$_{4}^{5}$ & P4222 & P 4c 2 \\
! 94 & D$_{4}^{6}$ & P42212 & P 4n 2n \\
! 95 & D$_{4}^{7}$ & P4322 & P 4cw 2c \\
! 96 & D$_{4}^{8}$ & P43212 & P 4nw 2abw \\
! 97 & D$_{4}^{9}$ & I422 & I 4 2 \\
! 98 & D$_{4}^{10}$ & I4122 & I 4bw 2bw \\
! 99 & C$_{4v}^{1}$ & P4mm & P 4 -2 \\
! 100 & C$_{4v}^{2}$ & P4bm & P 4 -2ab \\
! 101 & C$_{4v}^{3}$ & P42cm & P 4c -2c \\
! 102 & C$_{4v}^{4}$ & P42nm & P 4n -2n \\
! 103 & C$_{4v}^{5}$ & P4cc & P 4 -2c \\
! 104 & C$_{4v}^{6}$ & P4nc & P 4 -2n \\
! 105 & C$_{4v}^{7}$ & P42mc & P 4c -2 \\
! 106 & C$_{4v}^{8}$ & P42bc & P 4c -2ab \\
! 107 & C$_{4v}^{9}$ & I4mm & I 4 -2 \\
! 108 & C$_{4v}^{10}$ & I4cm & I 4 -2c \\
! 109 & C$_{4v}^{11}$ & I41md & I 4bw -2 \\
! 110 & C$_{4v}^{12}$ & I41cd & I 4bw -2c \\
! 111 & D$_{2d}^{1}$ & P-42m & P -4 2 \\
! 112 & D$_{2d}^{2}$ & P-42c & P -4 2c \\
! 113 & D$_{2d}^{3}$ & P-421m & P -4 2ab \\
! 114 & D$_{2d}^{4}$ & P-421c & P -4 2n \\
! 115 & D$_{2d}^{5}$ & P-4m2 & P -4 -2 \\
! 116 & D$_{2d}^{6}$ & P-4c2 & P -4 -2c \\
! 117 & D$_{2d}^{7}$ & P-4b2 & P -4 -2ab \\
! 118 & D$_{2d}^{8}$ & P-4n2 & P -4 -2n \\
! 119 & D$_{2d}^{9}$ & I-4m2 & I -4 -2 \\
! 120 & D$_{2d}^{10}$ & I-4c2 & I -4 -2c \\
! 121 & D$_{2d}^{11}$ & I-42m & I -4 2 \\
! 122 & D$_{2d}^{12}$ & I-42d & I -4 2bw \\
! 123 & D$_{4h}^{1}$ & P4/mmm & -P 4 2 \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 124 & D$_{4h}^{2}$ & P4/mcc & -P 4 2c \\
! 125:1 & D$_{4h}^{3}$ & P4/nbm:1 & P 4 2 -1ab \\
! 125:2 & D$_{4h}^{3}$ & P4/nbm:2 & -P 4a 2b \\
! 126:1 & D$_{4h}^{4}$ & P4/nnc:1 & P 4 2 -1n \\
! 126:2 & D$_{4h}^{4}$ & P4/nnc:2 & -P 4a 2bc \\
! 127 & D$_{4h}^{5}$ & P4/mbm & -P 4 2ab \\
! 128 & D$_{4h}^{6}$ & P4/mnc & -P 4 2n \\
! 129:1 & D$_{4h}^{7}$ & P4/nmm:1 & P 4ab 2ab -1ab \\
! 129:2 & D$_{4h}^{7}$ & P4/nmm:2 & -P 4a 2a \\
! 130:1 & D$_{4h}^{8}$ & P4/ncc:1 & P 4ab 2n -1ab \\
! 130:2 & D$_{4h}^{8}$ & P4/ncc:2 & -P 4a 2ac \\
! 131 & D$_{4h}^{9}$ & P42/mmc & -P 4c 2 \\
! 132 & D$_{4h}^{10}$ & P42/mcm & -P 4c 2c \\
! 133:1 & D$_{4h}^{11}$ & P42/nbc:1 & P 4n 2c -1n \\
! 133:2 & D$_{4h}^{11}$ & P42/nbc:2 & -P 4ac 2b \\
! 134:1 & D$_{4h}^{12}$ & P42/nnm:1 & P 4n 2 -1n \\
! 134:2 & D$_{4h}^{12}$ & P42/nnm:2 & -P 4ac 2bc \\
! 135 & D$_{4h}^{13}$ & P42/mbc & -P 4c 2ab \\
! 136 & D$_{4h}^{14}$ & P42/mnm & -P 4n 2n \\
! 137:1 & D$_{4h}^{15}$ & P42/nmc:1 & P 4n 2n -1n \\
! 137:2 & D$_{4h}^{15}$ & P42/nmc:2 & -P 4ac 2a \\
! 138:1 & D$_{4h}^{16}$ & P42/ncm:1 & P 4n 2ab -1n \\
! 138:2 & D$_{4h}^{16}$ & P42/ncm:2 & -P 4ac 2ac \\
! 139 & D$_{4h}^{17}$ & I4/mmm & -I 4 2 \\
! 140 & D$_{4h}^{18}$ & I4/mcm & -I 4 2c \\
! 141:1 & D$_{4h}^{19}$ & I41/amd:1 & I 4bw 2bw -1bw \\
! 141:2 & D$_{4h}^{19}$ & I41/amd:2 & -I 4bd 2 \\
! 142:1 & D$_{4h}^{20}$ & I41/acd:1 & I 4bw 2aw -1bw \\
! 142:2 & D$_{4h}^{20}$ & I41/acd:2 & -I 4bd 2c \\
! 143 & C$_{3}^{1}$ & P3 & P 3 \\
! 144 & C$_{3}^{2}$ & P31 & P 31 \\
! 145 & C$_{3}^{3}$ & P32 & P 32 \\
! 146:H & C$_{3}^{4}$ & R3:H & R 3 \\
! 146:R & C$_{3}^{4}$ & R3:R & P 3* \\
! 147 & C$_{3i}^{1}$ & P-3 & -P 3 \\
! 148:H & C$_{3i}^{2}$ & R-3:H & -R 3 \\
! 148:R & C$_{3i}^{2}$ & R-3:R & -P 3* \\
! 149 & D$_{3}^{1}$ & P312 & P 3 2 \\
! 150 & D$_{3}^{2}$ & P321 & P 3 2$''$ \\
! 151 & D$_{3}^{3}$ & P3112 & P 31 2c (0 0 1) \\
! 152 & D$_{3}^{4}$ & P3121 & P 31 2$''$ \\
! 153 & D$_{3}^{5}$ & P3212 & P 32 2c (0 0 -1) \\
! 154 & D$_{3}^{6}$ & P3221 & P 32 2$''$ \\
! 155:H & D$_{3}^{7}$ & R32:H & R 3 2$''$ \\
! 155:R & D$_{3}^{7}$ & R32:R & P 3* 2 \\
! 156 & C$_{3v}^{1}$ & P3m1 & P 3 -2$''$ \\
! 157 & C$_{3v}^{2}$ & P31m & P 3 -2 \\
! 158 & C$_{3v}^{3}$ & P3c1 & P 3 -2$''$c \\
! 159 & C$_{3v}^{4}$ & P31c & P 3 -2c \\
! 160:H & C$_{3v}^{5}$ & R3m:H & R 3 -2$''$ \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 160:R & C$_{3v}^{5}$ & R3m:R & P 3* -2 \\
! 161:H & C$_{3v}^{6}$ & R3c:H & R 3 -2$''$c \\
! 161:R & C$_{3v}^{6}$ & R3c:R & P 3* -2n \\
! 162 & D$_{3d}^{1}$ & P-31m & -P 3 2 \\
! 163 & D$_{3d}^{2}$ & P-31c & -P 3 2c \\
! 164 & D$_{3d}^{3}$ & P-3m1 & -P 3 2$''$ \\
! 165 & D$_{3d}^{4}$ & P-3c1 & -P 3 2$''$c \\
! 166:H & D$_{3d}^{5}$ & R-3m:H & -R 3 2$''$ \\
! 166:R & D$_{3d}^{5}$ & R-3m:R & -P 3* 2 \\
! 167:H & D$_{3d}^{6}$ & R-3c:H & -R 3 2$''$c \\
! 167:R & D$_{3d}^{6}$ & R-3c:R & -P 3* 2n \\
! 168 & C$_{6}^{1}$ & P6 & P 6 \\
! 169 & C$_{6}^{2}$ & P61 & P 61 \\
! 170 & C$_{6}^{3}$ & P65 & P 65 \\
! 171 & C$_{6}^{4}$ & P62 & P 62 \\
! 172 & C$_{6}^{5}$ & P64 & P 64 \\
! 173 & C$_{6}^{6}$ & P63 & P 6c \\
! 174 & C$_{3h}^{1}$ & P-6 & P -6 \\
! 175 & C$_{6h}^{1}$ & P6/m & -P 6 \\
! 176 & C$_{6h}^{2}$ & P63/m & -P 6c \\
! 177 & D$_{6}^{1}$ & P622 & P 6 2 \\
! 178 & D$_{6}^{2}$ & P6122 & P 61 2 (0 0 -1) \\
! 179 & D$_{6}^{3}$ & P6522 & P 65 2 (0 0 1) \\
! 180 & D$_{6}^{4}$ & P6222 & P 62 2c (0 0 1) \\
! 181 & D$_{6}^{5}$ & P6422 & P 64 2c (0 0 -1) \\
! 182 & D$_{6}^{6}$ & P6322 & P 6c 2c \\
! 183 & C$_{6v}^{1}$ & P6mm & P 6 -2 \\
! 184 & C$_{6v}^{2}$ & P6cc & P 6 -2c \\
! 185 & C$_{6v}^{3}$ & P63cm & P 6c -2 \\
! 186 & C$_{6v}^{4}$ & P63mc & P 6c -2c \\
! 187 & D$_{3h}^{1}$ & P-6m2 & P -6 2 \\
! 188 & D$_{3h}^{2}$ & P-6c2 & P -6c 2 \\
! 189 & D$_{3h}^{3}$ & P-62m & P -6 -2 \\
! 190 & D$_{3h}^{4}$ & P-62c & P -6c -2c \\
! 191 & D$_{6h}^{1}$ & P6/mmm & -P 6 2 \\
! 192 & D$_{6h}^{2}$ & P6/mcc & -P 6 2c \\
! 193 & D$_{6h}^{3}$ & P63/mcm & -P 6c 2 \\
! 194 & D$_{6h}^{4}$ & P63/mmc & -P 6c 2c \\
! 195 & T$_{}^{1}$ & P23 & P 2 2 3 \\
! 196 & T$_{}^{2}$ & F23 & F 2 2 3 \\
! 197 & T$_{}^{3}$ & I23 & I 2 2 3 \\
! 198 & T$_{}^{4}$ & P213 & P 2ac 2ab 3 \\
! 199 & T$_{}^{5}$ & I213 & I 2b 2c 3 \\
! 200 & T$_{h}^{1}$ & Pm-3 & -P 2 2 3 \\
! 201:1 & T$_{h}^{2}$ & Pn-3:1 & P 2 2 3 -1n \\
! 201:2 & T$_{h}^{2}$ & Pn-3:2 & -P 2ab 2bc 3 \\
! 202 & T$_{h}^{3}$ & Fm-3 & -F 2 2 3 \\
! 203:1 & T$_{h}^{4}$ & Fd-3:1 & F 2 2 3 -1d \\
! 203:2 & T$_{h}^{4}$ & Fd-3:2 & -F 2uv 2vw 3 \\
! 204 & T$_{h}^{5}$ & Im-3 & -I 2 2 3 \\
! \hline
! \end{tabular}
! \newpage
! \begin{tabular}{|l|l|l|l|}
! \hline
! Number & Schoenflies & Hermann-Mauguin & Hall \\
! \hline
! 205 & T$_{h}^{6}$ & Pa-3 & -P 2ac 2ab 3 \\
! 206 & T$_{h}^{7}$ & Ia-3 & -I 2b 2c 3 \\
! 207 & O$^{1}$ & P432 & P 4 2 3 \\
! 208 & O$^{2}$ & P4232 & P 4n 2 3 \\
! 209 & O$^{3}$ & F432 & F 4 2 3 \\
! 210 & O$^{4}$ & F4132 & F 4d 2 3 \\
! 211 & O$^{5}$ & I432 & I 4 2 3 \\
! 212 & O$^{6}$ & P4332 & P 4acd 2ab 3 \\
! 213 & O$^{7}$ & P4132 & P 4bd 2ab 3 \\
! 214 & O$^{8}$ & I4132 & I 4bd 2c 3 \\
! 215 & T$_{d}^{1}$ & P-43m & P -4 2 3 \\
! 216 & T$_{d}^{2}$ & F-43m & F -4 2 3 \\
! 217 & T$_{d}^{3}$ & I-43m & I -4 2 3 \\
! 218 & T$_{d}^{4}$ & P-43n & P -4n 2 3 \\
! 219 & T$_{d}^{5}$ & F-43c & F -4c 2 3 \\
! 220 & T$_{d}^{6}$ & I-43d & I -4bd 2c 3 \\
! 221 & O$_{h}^{1}$ & Pm-3m & -P 4 2 3 \\
! 222:1 & O$_{h}^{2}$ & Pn-3n:1 & P 4 2 3 -1n \\
! 222:2 & O$_{h}^{2}$ & Pn-3n:2 & -P 4a 2bc 3 \\
! 223 & O$_{h}^{3}$ & Pm-3n & -P 4n 2 3 \\
! 224:1 & O$_{h}^{4}$ & Pn-3m:1 & P 4n 2 3 -1n \\
! 224:2 & O$_{h}^{4}$ & Pn-3m:2 & -P 4bc 2bc 3 \\
! 225 & O$_{h}^{5}$ & Fm-3m & -F 4 2 3 \\
! 226 & O$_{h}^{6}$ & Fm-3c & -F 4c 2 3 \\
! 227:1 & O$_{h}^{7}$ & Fd-3m:1 & F 4d 2 3 -1d \\
! 227:2 & O$_{h}^{7}$ & Fd-3m:2 & -F 4vw 2vw 3 \\
! 228:1 & O$_{h}^{8}$ & Fd-3c:1 & F 4d 2 3 -1cd \\
! 228:2 & O$_{h}^{8}$ & Fd-3c:2 & -F 4cvw 2vw 3 \\
! 229 & O$_{h}^{9}$ & Im-3m & -I 4 2 3 \\
! 230 & O$_{h}^{10}$ & Ia-3d & -I 4bd 2c 3 \\
! \hline
! \end{tabular}
! \end{center}
!
!EOI
elk-7.2.42/src/spacegroup/PaxHeaders.21776/modmain.f90 0000644 0000000 0000000 00000000132 14061636515 017036 x ustar 00 30 mtime=1623670093.521103786
30 atime=1623670093.521103786
30 ctime=1623670093.521103786
elk-7.2.42/src/spacegroup/modmain.f90 0000644 0025044 0025044 00000004543 14061636515 021101 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !MODULE: modmain
! !DESCRIPTION:
! Contains all the global variables required by the spacegroup code.
!
! !REVISION HISTORY:
! Created October 2006 (JKD)
!EOP
!BOC
module modmain
!-------------------------------!
! space group variables !
!-------------------------------!
! Hermann-Mauguin symbol
character(20) hrmg
! space-group number
character(20) num
! Schoenflies symbol
character(20) schn
! Hall symbol
character(20) hall
!----------------------------!
! lattice parameters !
!----------------------------!
! number of unit cells
integer ncell(3)
! lattice vector lengths
real(8) a,b,c
! lattice vector angles
real(8) ab,ac,bc
! lattice vectors stored column-wise
real(8) avec(3,3)
! inverse of lattice vector matrix
real(8) ainv(3,3)
! any vector with length less than epslat is considered zero
real(8), parameter :: epslat=1.d-6
!--------------------------!
! atomic variables !
!--------------------------!
! maximum allowed species
integer, parameter :: maxspecies=8
! maximum allowed atoms per species
integer, parameter :: maxatoms=1000
! number of species
integer nspecies
! number of atoms for each species
integer natoms(maxspecies)
! total number of atoms
integer natmtot
! primcell is .true. if primitive unit cell is to be found automatically
logical primcell
! maximum allowed Wyckoff positions
integer, parameter :: maxwpos=100
! number of Wyckoff positions
integer nwpos(maxspecies)
! Wyckoff positions
real(8) wpos(3,maxwpos,maxspecies)
! atomic positions in lattice coordinates
real(8) atposl(3,maxatoms,maxspecies)
! atomic positions in Cartesian coordinates
real(8) atposc(3,maxatoms,maxspecies)
! magnetic fields
real(8) bfcmt0(3,maxatoms,maxspecies)
!----------------------------------!
! atomic species variables !
!----------------------------------!
! species symbol
character(256) spsymb(maxspecies)
!-----------------------------!
! numerical constants !
!-----------------------------!
real(8), parameter :: pi=3.1415926535897932385d0
!---------------------------------!
! miscellaneous variables !
!---------------------------------!
! code version
integer version(3)
data version / 1,2,1 /
end module
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/r3cross.f90 0000644 0000000 0000000 00000000132 14061636515 017010 x ustar 00 30 mtime=1623670093.523103784
30 atime=1623670093.522103785
30 ctime=1623670093.523103784
elk-7.2.42/src/spacegroup/r3cross.f90 0000644 0025044 0025044 00000001373 14061636515 021051 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: r3cross
! !INTERFACE:
subroutine r3cross(x,y,z)
! !INPUT/OUTPUT PARAMETERS:
! x : input vector 1 (in,real(3))
! y : input vector 2 (in,real(3))
! z : output cross-product (out,real(3))
! !DESCRIPTION:
! Returns the cross product of two real 3-vectors.
!
! !REVISION HISTORY:
! Created September 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: x(3)
real(8), intent(in) :: y(3)
real(8), intent(out) :: z(3)
z(1)=x(2)*y(3)-x(3)*y(2)
z(2)=x(3)*y(1)-x(1)*y(3)
z(3)=x(1)*y(2)-x(2)*y(1)
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/r3frac.f90 0000644 0000000 0000000 00000000132 14061636515 016572 x ustar 00 30 mtime=1623670093.524103783
30 atime=1623670093.524103783
30 ctime=1623670093.524103783
elk-7.2.42/src/spacegroup/r3frac.f90 0000644 0025044 0025044 00000001760 14061636515 020633 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: r3frac
! !INTERFACE:
subroutine r3frac(eps,v)
! !INPUT/OUTPUT PARAMETERS:
! eps : zero component tolerance (in,real)
! v : input vector (inout,real(3))
! !DESCRIPTION:
! Finds the fractional part of each component of a real 3-vector using the
! function ${\rm frac}\,(x)=x-\lfloor x\rfloor$. A component is taken to be
! zero if it lies within the intervals $[0,\epsilon)$ or $(1-\epsilon,1]$.
!
! !REVISION HISTORY:
! Created January 2003 (JKD)
! Removed iv, September 2011 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: eps
real(8), intent(inout) :: v(3)
! local variables
integer i
do i=1,3
v(i)=v(i)-int(v(i))
if (v(i).lt.0.d0) v(i)=v(i)+1.d0
if ((1.d0-v(i)).lt.eps) v(i)=0.d0
if (v(i).lt.eps) v(i)=0.d0
end do
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/r3minv.f90 0000644 0000000 0000000 00000000132 14061636515 016630 x ustar 00 30 mtime=1623670093.526103781
30 atime=1623670093.525103782
30 ctime=1623670093.526103781
elk-7.2.42/src/spacegroup/r3minv.f90 0000644 0025044 0025044 00000002362 14061636515 020670 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: r3minv
! !INTERFACE:
subroutine r3minv(a,b)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix (in,real(3,3))
! b : output matrix (in,real(3,3))
! !DESCRIPTION:
! Computes the inverse of a real $3\times 3$ matrix.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: a(3,3)
real(8), intent(out) :: b(3,3)
! local variables
real(8) t1
t1=a(1,2)*a(2,3)*a(3,1)-a(1,3)*a(2,2)*a(3,1)+a(1,3)*a(2,1)*a(3,2) &
-a(1,1)*a(2,3)*a(3,2)+a(1,1)*a(2,2)*a(3,3)-a(1,2)*a(2,1)*a(3,3)
if (abs(t1).lt.1.d-40) then
write(*,*)
write(*,'("Error(r3minv): singular matrix")')
write(*,*)
stop
end if
t1=1.d0/t1
b(1,1)=(a(2,2)*a(3,3)-a(2,3)*a(3,2))*t1
b(1,2)=(a(1,3)*a(3,2)-a(1,2)*a(3,3))*t1
b(1,3)=(a(1,2)*a(2,3)-a(1,3)*a(2,2))*t1
b(2,1)=(a(2,3)*a(3,1)-a(2,1)*a(3,3))*t1
b(2,2)=(a(1,1)*a(3,3)-a(1,3)*a(3,1))*t1
b(2,3)=(a(1,3)*a(2,1)-a(1,1)*a(2,3))*t1
b(3,1)=(a(2,1)*a(3,2)-a(2,2)*a(3,1))*t1
b(3,2)=(a(1,2)*a(3,1)-a(1,1)*a(3,2))*t1
b(3,3)=(a(1,1)*a(2,2)-a(1,2)*a(2,1))*t1
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/r3mm.f90 0000644 0000000 0000000 00000000127 14061636515 016274 x ustar 00 29 mtime=1623670093.52710378
29 atime=1623670093.52710378
29 ctime=1623670093.52710378
elk-7.2.42/src/spacegroup/r3mm.f90 0000644 0025044 0025044 00000002135 14061636515 020326 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: r3mm
! !INTERFACE:
subroutine r3mm(a,b,c)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix 1 (in,real(3,3))
! b : input matrix 2 (in,real(3,3))
! c : output matrix (out,real(3,3))
! !DESCRIPTION:
! Multiplies two real $3\times 3$ matrices.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: a(3,3)
real(8), intent(in) :: b(3,3)
real(8), intent(out) :: c(3,3)
c(1,1)=a(1,1)*b(1,1)+a(1,2)*b(2,1)+a(1,3)*b(3,1)
c(2,1)=a(2,1)*b(1,1)+a(2,2)*b(2,1)+a(2,3)*b(3,1)
c(3,1)=a(3,1)*b(1,1)+a(3,2)*b(2,1)+a(3,3)*b(3,1)
c(1,2)=a(1,1)*b(1,2)+a(1,2)*b(2,2)+a(1,3)*b(3,2)
c(2,2)=a(2,1)*b(1,2)+a(2,2)*b(2,2)+a(2,3)*b(3,2)
c(3,2)=a(3,1)*b(1,2)+a(3,2)*b(2,2)+a(3,3)*b(3,2)
c(1,3)=a(1,1)*b(1,3)+a(1,2)*b(2,3)+a(1,3)*b(3,3)
c(2,3)=a(2,1)*b(1,3)+a(2,2)*b(2,3)+a(2,3)*b(3,3)
c(3,3)=a(3,1)*b(1,3)+a(3,2)*b(2,3)+a(3,3)*b(3,3)
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/r3mv.f90 0000644 0000000 0000000 00000000132 14061636515 016301 x ustar 00 30 mtime=1623670093.528103779
30 atime=1623670093.528103779
30 ctime=1623670093.528103779
elk-7.2.42/src/spacegroup/r3mv.f90 0000644 0025044 0025044 00000001437 14061636515 020343 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: r3mv
! !INTERFACE:
subroutine r3mv(a,x,y)
! !INPUT/OUTPUT PARAMETERS:
! a : input matrix (in,real(3,3))
! x : input vector (in,real(3))
! y : output vector (out,real(3))
! !DESCRIPTION:
! Multiplies a real $3\times 3$ matrix with a vector.
!
! !REVISION HISTORY:
! Created January 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
real(8), intent(in) :: a(3,3)
real(8), intent(in) :: x(3)
real(8), intent(out) :: y(3)
y(1)=a(1,1)*x(1)+a(1,2)*x(2)+a(1,3)*x(3)
y(2)=a(2,1)*x(1)+a(2,2)*x(2)+a(2,3)*x(3)
y(3)=a(3,1)*x(1)+a(3,2)*x(2)+a(3,3)*x(3)
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/readinput.f90 0000644 0000000 0000000 00000000132 14061636515 017405 x ustar 00 30 mtime=1623670093.530103777
30 atime=1623670093.530103777
30 ctime=1623670093.530103777
elk-7.2.42/src/spacegroup/readinput.f90 0000644 0025044 0025044 00000003003 14061636515 021436 0 ustar 00dewhurst dewhurst 0000000 0000000 subroutine readinput
use modmain
implicit none
! local variables
integer is,ip
open(50,file='spacegroup.in',action='READ',status='OLD',form='FORMATTED')
! read the Hermann-Mauguin symbol
read(50,*) hrmg
hrmg=adjustl(hrmg)
! read lattice vector lengths
read(50,*) a,b,c
! read angles between lattice vectors: alpha, beta, gamma
! (convention fixed by F. Cricchio)
read(50,*) bc,ac,ab
! read number of unit cells
read(50,*) ncell
if ((ncell(1).lt.1).or.(ncell(2).lt.1).or.(ncell(3).lt.1)) then
write(*,*)
write(*,'("Error(readinput): invalid ncell : ",3I8)') ncell
write(*,*)
stop
end if
read(50,*) primcell
read(50,*) nspecies
if (nspecies.le.0) then
write(*,*)
write(*,'("Error(readinput): nspecies <= 0 : ",I8)') nspecies
write(*,*)
stop
end if
if (nspecies.gt.maxspecies) then
write(*,*)
write(*,'("Error(readinput): nspecies too large : ",I8)') nspecies
write(*,'("Adjust maxspecies and recompile code")')
write(*,*)
stop
end if
do is=1,nspecies
read(50,*) spsymb(is)
read(50,*) nwpos(is)
if (nwpos(is).le.0) then
write(*,*)
write(*,'("Error(readinput): nwpos <= 0 : ",I8)') nwpos(is)
write(*,'(" for species ",I4)') is
write(*,*)
stop
end if
if (nwpos(is).gt.maxwpos) then
write(*,*)
write(*,'("Error(readinput): nwpos too large : ",I8)') nwpos(is)
write(*,'(" for species ",I4)') is
write(*,'("Adjust maxwpos and reompile code")')
write(*,*)
stop
end if
do ip=1,nwpos(is)
read(50,*) wpos(:,ip,is)
end do
end do
close(50)
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/seitzeq.f90 0000644 0000000 0000000 00000000132 14061636515 017076 x ustar 00 30 mtime=1623670093.531103777
30 atime=1623670093.531103777
30 ctime=1623670093.531103777
elk-7.2.42/src/spacegroup/seitzeq.f90 0000644 0025044 0025044 00000001271 14061636515 021134 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
logical function seitzeq(eps,sr1,st1,sr2,st2)
implicit none
! arguments
real(8), intent(in) :: eps
real(8), intent(in) :: sr1(3,3)
real(8), intent(in) :: st1(3)
real(8), intent(in) :: sr2(3,3)
real(8), intent(in) :: st2(3)
! local variables
integer j
real(8) v1(3),v2(3)
seitzeq=.false.
do j=1,3
v1(:)=sr1(:,j)+st1(:)
v2(:)=sr2(:,j)+st2(:)
if ((abs(v1(1)-v2(1)).gt.eps).or. &
(abs(v1(2)-v2(2)).gt.eps).or. &
(abs(v1(3)-v2(3)).gt.eps)) return
end do
seitzeq=.true.
return
end function
elk-7.2.42/src/spacegroup/PaxHeaders.21776/seitzgen.f90 0000644 0000000 0000000 00000000132 14061636515 017242 x ustar 00 30 mtime=1623670093.533103775
30 atime=1623670093.533103775
30 ctime=1623670093.533103775
elk-7.2.42/src/spacegroup/seitzgen.f90 0000644 0025044 0025044 00000025667 14061636515 021317 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine seitzgen(hall,ngen,srgen,stgen)
implicit none
character(20), intent(in) :: hall
integer, intent(out) :: ngen
real(8), intent(out) :: srgen(3,3,12)
real(8), intent(out) :: stgen(3,12)
! local variables
logical pr
integer i,m,n,no,nop,axis
! zero vector tolerance
real(8), parameter :: eps=1.d-6
real(8) av(3),r(3,3),t1
real(8) v1(3),v2(3),v3(3)
character(20) str1,str2,str3
str1=trim(adjustl(hall))//' '
no=0
nop=0
axis=0
n=0
10 continue
! check for origin shift vector
if (scan(str1,'(').eq.1) then
if (index(str1,'(0 0 1)').ne.0) then
v1(1)=0.d0; v1(2)=0.d0; v1(3)=1.d0
else if (index(str1,'(0 0 -1)').ne.0) then
v1(1)=0.d0; v1(2)=0.d0; v1(3)=-1.d0
else
write(*,*)
write(*,'("Error(seitzgen): origin-shift not available : ",A)') trim(str1)
write(*,*)
stop
end if
v1(:)=v1(:)/12.d0
! apply vector shift to all Seitz matrices
do i=1,ngen
v3(:)=-v1(:)
call r3mv(srgen(:,:,i),v3,v2)
v2(:)=v2(:)+stgen(:,i)
stgen(:,i)=v2(:)+v1(:)
end do
goto 20
end if
m=scan(str1,' ')
if (m.le.1) goto 20
str2=str1(1:m-1)
n=n+1
!------------------------------!
! lattice translations !
!------------------------------!
if (n.eq.1) then
stgen(:,1)=0.d0
if (scan(str2,'P').ne.0) then
ngen=1
else if (scan(str2,'A').ne.0) then
stgen(1,2)=0.d0
stgen(2,2)=0.5d0
stgen(3,2)=0.5d0
ngen=2
else if (scan(str2,'B').ne.0) then
stgen(1,2)=0.5d0
stgen(2,2)=0.d0
stgen(3,2)=0.5d0
ngen=2
else if (scan(str2,'C').ne.0) then
stgen(1,2)=0.5d0
stgen(2,2)=0.5d0
stgen(3,2)=0.d0
ngen=2
else if (scan(str2,'I').ne.0) then
stgen(:,2)=0.5d0
ngen=2
else if (scan(str2,'R').ne.0) then
stgen(1,2)=0.6666666666666666667d0
stgen(2,2)=0.3333333333333333333d0
stgen(3,2)=0.3333333333333333333d0
stgen(1,3)=0.3333333333333333333d0
stgen(2,3)=0.6666666666666666667d0
stgen(3,3)=0.6666666666666666667d0
ngen=3
else if (scan(str2,'S').ne.0) then
stgen(1,2)=0.3333333333333333333d0
stgen(2,2)=0.3333333333333333333d0
stgen(3,2)=0.6666666666666666667d0
stgen(1,3)=0.6666666666666666667d0
stgen(2,3)=0.6666666666666666667d0
stgen(3,3)=0.3333333333333333333d0
ngen=3
else if (scan(str2,'T').ne.0) then
stgen(1,2)=0.3333333333333333333d0
stgen(2,2)=0.6666666666666666667d0
stgen(3,2)=0.3333333333333333333d0
stgen(1,3)=0.6666666666666666667d0
stgen(2,3)=0.3333333333333333333d0
stgen(3,3)=0.6666666666666666667d0
ngen=3
else if (scan(str2,'F').ne.0) then
stgen(1,2)=0.d0
stgen(2,2)=0.5d0
stgen(3,2)=0.5d0
stgen(1,3)=0.5d0
stgen(2,3)=0.d0
stgen(3,3)=0.5d0
stgen(1,4)=0.5d0
stgen(2,4)=0.5d0
stgen(3,4)=0.d0
ngen=4
else
write(*,*)
write(*,'("Error(seitzgen): Lattice symbol ''",A,"'' not found")') &
trim(str2)
write(*,*)
stop
end if
! set the rotations to the identity
do i=1,ngen
srgen(1,1,i)=1.d0; srgen(1,2,i)=0.d0; srgen(1,3,i)=0.d0
srgen(2,1,i)=0.d0; srgen(2,2,i)=1.d0; srgen(2,3,i)=0.d0
srgen(3,1,i)=0.d0; srgen(3,2,i)=0.d0; srgen(3,3,i)=1.d0
end do
! check if lattice is centrosymmetric
if (scan(str2,'-').ne.0) then
do i=ngen+1,2*ngen
srgen(:,:,i)=-srgen(:,:,i-ngen)
stgen(:,i)=stgen(:,i-ngen)
end do
ngen=2*ngen
end if
end if
!-------------------------------!
! rotation-translations !
!-------------------------------!
if (n.ge.2) then
! determine if rotation is proper or improper
if (scan(str2,'-').eq.1) then
pr=.false.
! remove the minus sign
str3=str2(2:)
str2=str3
else
pr=.true.
end if
! determine the order of rotation
if (scan(str2,'1').eq.1) then
no=1
else if (scan(str2,'2').eq.1) then
no=2
else if (scan(str2,'3').eq.1) then
no=3
else if (scan(str2,'4').eq.1) then
no=4
else if (scan(str2,'6').eq.1) then
no=6
else
write(*,*)
write(*,'("Error(seitzgen): invalid rotation order for Hall symbol ''",A,&
&"''")') trim(hall)
write(*,*)
stop
end if
! determine the axis of rotation
if (scan(str2,'x').ne.0) then
! a axis
axis=1
else if (scan(str2,'y').ne.0) then
! b axis
axis=2
else if (scan(str2,'z').ne.0) then
! c axis
axis=3
else if (scan(str2,'"').ne.0) then
! a+b
axis=5
else if (scan(str2,'*').ne.0) then
! a+b+c axis
axis=6
else if (n.eq.2) then
! default first rotation is along c
axis=3
else if ((n.eq.3).and.(no.eq.2)) then
! default second rotation
if ((nop.eq.2).or.(nop.eq.4)) then
! a axis
axis=1
else if ((nop.eq.3).or.(nop.eq.6)) then
! a-b axis
axis=4
else
write(*,*)
write(*,'("Error(seitzgen): malformed Hall symbol ''",A,"''")') trim(hall)
write(*,'(" for default second rotation")')
write(*,*)
stop
end if
else if ((n.eq.4).and.(no.eq.3)) then
! third rotation around a+b+c axis
axis=6
else if (no.eq.1) then
! arbitrary axis for identity
axis=1
else
write(*,*)
write(*,'("Error(seitzgen): malformed Hall symbol ''",A,"''")') trim(hall)
write(*,*)
stop
end if
! determine axis vector
av(:)=0.d0
if (axis.eq.1) then
! a axis
av(1)=1.d0
else if (axis.eq.2) then
! b axis
av(2)=1.d0
else if (axis.eq.3) then
! c axis
av(3)=1.d0
else if (axis.eq.4) then
! a-b axis
av(1)=1.d0
av(2)=-1.d0
else if (axis.eq.5) then
! a+b axis
av(1)=1.d0
av(2)=1.d0
else if (axis.eq.6) then
! a+b+c axis
av(:)=1.d0
end if
! compute the rotation part of the Seitz matrix
if (axis.eq.1) then
! a axis
if (no.eq.1) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.2) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)=-1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)=-1.d0
else if (no.eq.3) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 0.d0; r(2,3)=-1.d0
r(3,1)= 0.d0; r(3,2)= 1.d0; r(3,3)=-1.d0
else if (no.eq.4) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 0.d0; r(2,3)=-1.d0
r(3,1)= 0.d0; r(3,2)= 1.d0; r(3,3)= 0.d0
else if (no.eq.6) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)=-1.d0
r(3,1)= 0.d0; r(3,2)= 1.d0; r(3,3)= 0.d0
end if
else if (axis.eq.2) then
! b axis
if (no.eq.1) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.2) then
r(1,1)=-1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)=-1.d0
else if (no.eq.3) then
r(1,1)=-1.d0; r(1,2)= 0.d0; r(1,3)= 1.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)=-1.d0; r(3,2)= 0.d0; r(3,3)= 0.d0
else if (no.eq.4) then
r(1,1)= 0.d0; r(1,2)= 0.d0; r(1,3)= 1.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)=-1.d0; r(3,2)= 0.d0; r(3,3)= 0.d0
else if (no.eq.6) then
r(1,1)= 0.d0; r(1,2)= 0.d0; r(1,3)= 1.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)=-1.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
end if
else if (axis.eq.3) then
! c axis
if (no.eq.1) then
r(1,1)= 1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)= 1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.2) then
r(1,1)=-1.d0; r(1,2)= 0.d0; r(1,3)= 0.d0
r(2,1)= 0.d0; r(2,2)=-1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.3) then
r(1,1)= 0.d0; r(1,2)=-1.d0; r(1,3)= 0.d0
r(2,1)= 1.d0; r(2,2)=-1.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.4) then
r(1,1)= 0.d0; r(1,2)=-1.d0; r(1,3)= 0.d0
r(2,1)= 1.d0; r(2,2)= 0.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
else if (no.eq.6) then
r(1,1)= 1.d0; r(1,2)=-1.d0; r(1,3)= 0.d0
r(2,1)= 1.d0; r(2,2)= 0.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)= 1.d0
end if
else if (axis.eq.4) then
! a-b axis
r(1,1)= 0.d0; r(1,2)=-1.d0; r(1,3)= 0.d0
r(2,1)=-1.d0; r(2,2)= 0.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)=-1.d0
else if (axis.eq.5) then
! a+b axis
r(1,1)= 0.d0; r(1,2)= 1.d0; r(1,3)= 0.d0
r(2,1)= 1.d0; r(2,2)= 0.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 0.d0; r(3,3)=-1.d0
else if (axis.eq.6) then
! a+b+c axis
r(1,1)= 0.d0; r(1,2)= 0.d0; r(1,3)= 1.d0
r(2,1)= 1.d0; r(2,2)= 0.d0; r(2,3)= 0.d0
r(3,1)= 0.d0; r(3,2)= 1.d0; r(3,3)= 0.d0
end if
! check if axis is invariant with respect to rotation
call r3mv(r,av,v1)
t1=sum(abs(av(:)-v1(:)))
if (t1.gt.eps) then
write(*,*)
write(*,'("Error(seitzgen): axis not invariant with respect to rotation")')
write(*,'(" for Hall symbol ''",A,"''")') trim(hall)
write(*,*)
stop
end if
! apply inverse for improper rotation
if (.not.pr) r(:,:)=-r(:,:)
! increment Seitz matrix count
ngen=ngen+1
! store rotation in main array
srgen(:,:,ngen)=r(:,:)
! remove rotation symbol
str3=str2(2:)
str2=str3
! determine translations
stgen(:,ngen)=0.d0
if (scan(str2,'a').ne.0) then
stgen(1,ngen)=stgen(1,ngen)+0.5d0
end if
if (scan(str2,'b').ne.0) then
stgen(2,ngen)=stgen(2,ngen)+0.5d0
end if
if (scan(str2,'c').ne.0) then
stgen(3,ngen)=stgen(3,ngen)+0.5d0
end if
if (scan(str2,'n').ne.0) then
stgen(:,ngen)=stgen(:,ngen)+0.5d0
end if
if (scan(str2,'u').ne.0) then
stgen(1,ngen)=stgen(1,ngen)+0.25d0
end if
if (scan(str2,'v').ne.0) then
stgen(2,ngen)=stgen(2,ngen)+0.25d0
end if
if (scan(str2,'w').ne.0) then
stgen(3,ngen)=stgen(3,ngen)+0.25d0
end if
if (scan(str2,'d').ne.0) then
stgen(:,ngen)=stgen(:,ngen)+0.25d0
end if
if (scan(str2,'1').ne.0) then
if (no.eq.3) then
stgen(:,ngen)=stgen(:,ngen)+0.3333333333333333333d0*av(:)
else if (no.eq.4) then
stgen(:,ngen)=stgen(:,ngen)+0.25d0*av(:)
else if (no.eq.6) then
stgen(:,ngen)=stgen(:,ngen)+0.1666666666666666667d0*av(:)
end if
else if (scan(str2,'2').ne.0) then
if (no.eq.3) then
stgen(:,ngen)=stgen(:,ngen)+0.6666666666666666667d0*av(:)
else if (no.eq.6) then
stgen(:,ngen)=stgen(:,ngen)+0.3333333333333333333d0*av(:)
end if
else if (scan(str2,'3').ne.0) then
if (no.eq.4) then
stgen(:,ngen)=stgen(:,ngen)+0.75d0*av(:)
end if
else if (scan(str2,'4').ne.0) then
if (no.eq.6) then
stgen(:,ngen)=stgen(:,ngen)+0.6666666666666666667d0*av(:)
end if
else if (scan(str2,'5').ne.0) then
if (no.eq.6) then
stgen(:,ngen)=stgen(:,ngen)+0.8333333333333333333d0*av(:)
end if
end if
end if
str3=adjustl(str1(m:))
str1=str3
nop=no
goto 10
20 continue
! map translations to [0,1)
do i=1,ngen
call r3frac(eps,stgen(:,i))
end do
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/seitzmul.f90 0000644 0000000 0000000 00000000132 14061636515 017266 x ustar 00 30 mtime=1623670093.535103773
30 atime=1623670093.534103774
30 ctime=1623670093.535103773
elk-7.2.42/src/spacegroup/seitzmul.f90 0000644 0025044 0025044 00000001123 14061636515 021320 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine seitzmul(eps,sr1,st1,sr2,st2,sr3,st3)
implicit none
! arguments
real(8), intent(in) :: eps
real(8), intent(in) :: sr1(3,3)
real(8), intent(in) :: st1(3)
real(8), intent(in) :: sr2(3,3)
real(8), intent(in) :: st2(3)
real(8), intent(out) :: sr3(3,3)
real(8), intent(out) :: st3(3)
call r3mv(sr1,st2,st3)
st3(:)=st3(:)+st1(:)
call r3frac(eps,st3)
call r3mm(sr1,sr2,sr3)
return
end subroutine
elk-7.2.42/src/spacegroup/PaxHeaders.21776/sgsymb.f90 0000644 0000000 0000000 00000000132 14061636515 016716 x ustar 00 30 mtime=1623670093.536103772
30 atime=1623670093.536103772
30 ctime=1623670093.536103772
elk-7.2.42/src/spacegroup/sgsymb.f90 0000644 0025044 0025044 00000100400 14061636515 020746 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: sgsymb
! !INTERFACE:
subroutine sgsymb(hrmg,num,schn,hall)
! !INPUT/OUTPUT PARAMETERS:
! hrmg : Hermann-Mauguin symbol (in,character(20))
! num : space group number (out,character(20))
! schn : Schoenflies symbol (out,character(20))
! hall : Hall symbol (out,character(20))
! !DESCRIPTION:
! Returns the space group number, Schoenflies and Hall symbols given the
! Hermann-Mauguin symbol. The routine is case-sensitive. With acknowledgements
! to Ralf W. Grosse-Kunstleve and the tables available at
! {\tt http://cci.lbl.gov/sginfo/}.
!
! !REVISION HISTORY:
! Created October 2006 (JKD)
!EOP
!BOC
implicit none
! arguments
character(20), intent(in) :: hrmg
character(20), intent(out) :: num
character(20), intent(out) :: schn
character(20), intent(out) :: hall
select case(trim(adjustl(hrmg)))
case('P1')
num='1'
schn='C1^1'
hall='P 1'
case('P-1')
num='2'
schn='Ci^1'
hall='-P 1'
case('P2:b')
num='3:b'
schn='C2^1'
hall='P 2y'
case('P2:c')
num='3:c'
schn='C2^1'
hall='P 2'
case('P2:a')
num='3:a'
schn='C2^1'
hall='P 2x'
case('P21:b')
num='4:b'
schn='C2^2'
hall='P 2yb'
case('P21:c')
num='4:c'
schn='C2^2'
hall='P 2c'
case('P21:a')
num='4:a'
schn='C2^2'
hall='P 2xa'
case('C2:b1')
num='5:b1'
schn='C2^3'
hall='C 2y'
case('C2:b2')
num='5:b2'
schn='C2^3'
hall='A 2y'
case('C2:b3')
num='5:b3'
schn='C2^3'
hall='I 2y'
case('C2:c1')
num='5:c1'
schn='C2^3'
hall='A 2'
case('C2:c2')
num='5:c2'
schn='C2^3'
hall='B 2'
case('C2:c3')
num='5:c3'
schn='C2^3'
hall='I 2'
case('C2:a1')
num='5:a1'
schn='C2^3'
hall='B 2x'
case('C2:a2')
num='5:a2'
schn='C2^3'
hall='C 2x'
case('C2:a3')
num='5:a3'
schn='C2^3'
hall='I 2x'
case('Pm:b')
num='6:b'
schn='Cs^1'
hall='P -2y'
case('Pm:c')
num='6:c'
schn='Cs^1'
hall='P -2'
case('Pm:a')
num='6:a'
schn='Cs^1'
hall='P -2x'
case('Pc:b1')
num='7:b1'
schn='Cs^2'
hall='P -2yc'
case('Pc:b2')
num='7:b2'
schn='Cs^2'
hall='P -2yac'
case('Pc:b3')
num='7:b3'
schn='Cs^2'
hall='P -2ya'
case('Pc:c1')
num='7:c1'
schn='Cs^2'
hall='P -2a'
case('Pc:c2')
num='7:c2'
schn='Cs^2'
hall='P -2ab'
case('Pc:c3')
num='7:c3'
schn='Cs^2'
hall='P -2b'
case('Pc:a1')
num='7:a1'
schn='Cs^2'
hall='P -2xb'
case('Pc:a2')
num='7:a2'
schn='Cs^2'
hall='P -2xbc'
case('Pc:a3')
num='7:a3'
schn='Cs^2'
hall='P -2xc'
case('Cm:b1')
num='8:b1'
schn='Cs^3'
hall='C -2y'
case('Cm:b2')
num='8:b2'
schn='Cs^3'
hall='A -2y'
case('Cm:b3')
num='8:b3'
schn='Cs^3'
hall='I -2y'
case('Cm:c1')
num='8:c1'
schn='Cs^3'
hall='A -2'
case('Cm:c2')
num='8:c2'
schn='Cs^3'
hall='B -2'
case('Cm:c3')
num='8:c3'
schn='Cs^3'
hall='I -2'
case('Cm:a1')
num='8:a1'
schn='Cs^3'
hall='B -2x'
case('Cm:a2')
num='8:a2'
schn='Cs^3'
hall='C -2x'
case('Cm:a3')
num='8:a3'
schn='Cs^3'
hall='I -2x'
case('Cc:b1')
num='9:b1'
schn='Cs^4'
hall='C -2yc'
case('Cc:b2')
num='9:b2'
schn='Cs^4'
hall='A -2yac'
case('Cc:b3')
num='9:b3'
schn='Cs^4'
hall='I -2ya'
case('Cc:-b1')
num='9:-b1'
schn='Cs^4'
hall='A -2ya'
case('Cc:-b2')
num='9:-b2'
schn='Cs^4'
hall='C -2ybc'
case('Cc:-b3')
num='9:-b3'
schn='Cs^4'
hall='I -2yc'
case('Cc:c1')
num='9:c1'
schn='Cs^4'
hall='A -2a'
case('Cc:c2')
num='9:c2'
schn='Cs^4'
hall='B -2bc'
case('Cc:c3')
num='9:c3'
schn='Cs^4'
hall='I -2b'
case('Cc:-c1')
num='9:-c1'
schn='Cs^4'
hall='B -2b'
case('Cc:-c2')
num='9:-c2'
schn='Cs^4'
hall='A -2ac'
case('Cc:-c3')
num='9:-c3'
schn='Cs^4'
hall='I -2a'
case('Cc:a1')
num='9:a1'
schn='Cs^4'
hall='B -2xb'
case('Cc:a2')
num='9:a2'
schn='Cs^4'
hall='C -2xbc'
case('Cc:a3')
num='9:a3'
schn='Cs^4'
hall='I -2xc'
case('Cc:-a1')
num='9:-a1'
schn='Cs^4'
hall='C -2xc'
case('Cc:-a2')
num='9:-a2'
schn='Cs^4'
hall='B -2xbc'
case('Cc:-a3')
num='9:-a3'
schn='Cs^4'
hall='I -2xb'
case('P2/m:b')
num='10:b'
schn='C2h^1'
hall='-P 2y'
case('P2/m:c')
num='10:c'
schn='C2h^1'
hall='-P 2'
case('P2/m:a')
num='10:a'
schn='C2h^1'
hall='-P 2x'
case('P21/m:b')
num='11:b'
schn='C2h^2'
hall='-P 2yb'
case('P21/m:c')
num='11:c'
schn='C2h^2'
hall='-P 2c'
case('P21/m:a')
num='11:a'
schn='C2h^2'
hall='-P 2xa'
case('C2/m:b1')
num='12:b1'
schn='C2h^3'
hall='-C 2y'
case('C2/m:b2')
num='12:b2'
schn='C2h^3'
hall='-A 2y'
case('C2/m:b3')
num='12:b3'
schn='C2h^3'
hall='-I 2y'
case('C2/m:c1')
num='12:c1'
schn='C2h^3'
hall='-A 2'
case('C2/m:c2')
num='12:c2'
schn='C2h^3'
hall='-B 2'
case('C2/m:c3')
num='12:c3'
schn='C2h^3'
hall='-I 2'
case('C2/m:a1')
num='12:a1'
schn='C2h^3'
hall='-B 2x'
case('C2/m:a2')
num='12:a2'
schn='C2h^3'
hall='-C 2x'
case('C2/m:a3')
num='12:a3'
schn='C2h^3'
hall='-I 2x'
case('P2/c:b1')
num='13:b1'
schn='C2h^4'
hall='-P 2yc'
case('P2/c:b2')
num='13:b2'
schn='C2h^4'
hall='-P 2yac'
case('P2/c:b3')
num='13:b3'
schn='C2h^4'
hall='-P 2ya'
case('P2/c:c1')
num='13:c1'
schn='C2h^4'
hall='-P 2a'
case('P2/c:c2')
num='13:c2'
schn='C2h^4'
hall='-P 2ab'
case('P2/c:c3')
num='13:c3'
schn='C2h^4'
hall='-P 2b'
case('P2/c:a1')
num='13:a1'
schn='C2h^4'
hall='-P 2xb'
case('P2/c:a2')
num='13:a2'
schn='C2h^4'
hall='-P 2xbc'
case('P2/c:a3')
num='13:a3'
schn='C2h^4'
hall='-P 2xc'
case('P21/c:b1')
num='14:b1'
schn='C2h^5'
hall='-P 2ybc'
case('P21/c:b2')
num='14:b2'
schn='C2h^5'
hall='-P 2yn'
case('P21/c:b3')
num='14:b3'
schn='C2h^5'
hall='-P 2yab'
case('P21/c:c1')
num='14:c1'
schn='C2h^5'
hall='-P 2ac'
case('P21/c:c2')
num='14:c2'
schn='C2h^5'
hall='-P 2n'
case('P21/c:c3')
num='14:c3'
schn='C2h^5'
hall='-P 2bc'
case('P21/c:a1')
num='14:a1'
schn='C2h^5'
hall='-P 2xab'
case('P21/c:a2')
num='14:a2'
schn='C2h^5'
hall='-P 2xn'
case('P21/c:a3')
num='14:a3'
schn='C2h^5'
hall='-P 2xac'
case('C2/c:b1')
num='15:b1'
schn='C2h^6'
hall='-C 2yc'
case('C2/c:b2')
num='15:b2'
schn='C2h^6'
hall='-A 2yac'
case('C2/c:b3')
num='15:b3'
schn='C2h^6'
hall='-I 2ya'
case('C2/c:-b1')
num='15:-b1'
schn='C2h^6'
hall='-A 2ya'
case('C2/c:-b2')
num='15:-b2'
schn='C2h^6'
hall='-C 2ybc'
case('C2/c:-b3')
num='15:-b3'
schn='C2h^6'
hall='-I 2yc'
case('C2/c:c1')
num='15:c1'
schn='C2h^6'
hall='-A 2a'
case('C2/c:c2')
num='15:c2'
schn='C2h^6'
hall='-B 2bc'
case('C2/c:c3')
num='15:c3'
schn='C2h^6'
hall='-I 2b'
case('C2/c:-c1')
num='15:-c1'
schn='C2h^6'
hall='-B 2b'
case('C2/c:-c2')
num='15:-c2'
schn='C2h^6'
hall='-A 2ac'
case('C2/c:-c3')
num='15:-c3'
schn='C2h^6'
hall='-I 2a'
case('C2/c:a1')
num='15:a1'
schn='C2h^6'
hall='-B 2xb'
case('C2/c:a2')
num='15:a2'
schn='C2h^6'
hall='-C 2xbc'
case('C2/c:a3')
num='15:a3'
schn='C2h^6'
hall='-I 2xc'
case('C2/c:-a1')
num='15:-a1'
schn='C2h^6'
hall='-C 2xc'
case('C2/c:-a2')
num='15:-a2'
schn='C2h^6'
hall='-B 2xbc'
case('C2/c:-a3')
num='15:-a3'
schn='C2h^6'
hall='-I 2xb'
case('P222')
num='16'
schn='D2^1'
hall='P 2 2'
case('P2221')
num='17'
schn='D2^2'
hall='P 2c 2'
case('P2122')
num='17:cab'
schn='D2^2'
hall='P 2a 2a'
case('P2212')
num='17:bca'
schn='D2^2'
hall='P 2 2b'
case('P21212')
num='18'
schn='D2^3'
hall='P 2 2ab'
case('P22121')
num='18:cab'
schn='D2^3'
hall='P 2bc 2'
case('P21221')
num='18:bca'
schn='D2^3'
hall='P 2ac 2ac'
case('P212121')
num='19'
schn='D2^4'
hall='P 2ac 2ab'
case('C2221')
num='20'
schn='D2^5'
hall='C 2c 2'
case('A2122')
num='20:cab'
schn='D2^5'
hall='A 2a 2a'
case('B2212')
num='20:bca'
schn='D2^5'
hall='B 2 2b'
case('C222')
num='21'
schn='D2^6'
hall='C 2 2'
case('A222')
num='21:cab'
schn='D2^6'
hall='A 2 2'
case('B222')
num='21:bca'
schn='D2^6'
hall='B 2 2'
case('F222')
num='22'
schn='D2^7'
hall='F 2 2'
case('I222')
num='23'
schn='D2^8'
hall='I 2 2'
case('I212121')
num='24'
schn='D2^9'
hall='I 2b 2c'
case('Pmm2')
num='25'
schn='C2v^1'
hall='P 2 -2'
case('P2mm')
num='25:cab'
schn='C2v^1'
hall='P -2 2'
case('Pm2m')
num='25:bca'
schn='C2v^1'
hall='P -2 -2'
case('Pmc21')
num='26'
schn='C2v^2'
hall='P 2c -2'
case('Pcm21')
num='26:ba-c'
schn='C2v^2'
hall='P 2c -2c'
case('P21ma')
num='26:cab'
schn='C2v^2'
hall='P -2a 2a'
case('P21am')
num='26:-cba'
schn='C2v^2'
hall='P -2 2a'
case('Pb21m')
num='26:bca'
schn='C2v^2'
hall='P -2 -2b'
case('Pm21b')
num='26:a-cb'
schn='C2v^2'
hall='P -2b -2'
case('Pcc2')
num='27'
schn='C2v^3'
hall='P 2 -2c'
case('P2aa')
num='27:cab'
schn='C2v^3'
hall='P -2a 2'
case('Pb2b')
num='27:bca'
schn='C2v^3'
hall='P -2b -2b'
case('Pma2')
num='28'
schn='C2v^4'
hall='P 2 -2a'
case('Pbm2')
num='28:ba-c'
schn='C2v^4'
hall='P 2 -2b'
case('P2mb')
num='28:cab'
schn='C2v^4'
hall='P -2b 2'
case('P2cm')
num='28:-cba'
schn='C2v^4'
hall='P -2c 2'
case('Pc2m')
num='28:bca'
schn='C2v^4'
hall='P -2c -2c'
case('Pm2a')
num='28:a-cb'
schn='C2v^4'
hall='P -2a -2a'
case('Pca21')
num='29'
schn='C2v^5'
hall='P 2c -2ac'
case('Pbc21')
num='29:ba-c'
schn='C2v^5'
hall='P 2c -2b'
case('P21ab')
num='29:cab'
schn='C2v^5'
hall='P -2b 2a'
case('P21ca')
num='29:-cba'
schn='C2v^5'
hall='P -2ac 2a'
case('Pc21b')
num='29:bca'
schn='C2v^5'
hall='P -2bc -2c'
case('Pb21a')
num='29:a-cb'
schn='C2v^5'
hall='P -2a -2ab'
case('Pnc2')
num='30'
schn='C2v^6'
hall='P 2 -2bc'
case('Pcn2')
num='30:ba-c'
schn='C2v^6'
hall='P 2 -2ac'
case('P2na')
num='30:cab'
schn='C2v^6'
hall='P -2ac 2'
case('P2an')
num='30:-cba'
schn='C2v^6'
hall='P -2ab 2'
case('Pb2n')
num='30:bca'
schn='C2v^6'
hall='P -2ab -2ab'
case('Pn2b')
num='30:a-cb'
schn='C2v^6'
hall='P -2bc -2bc'
case('Pmn21')
num='31'
schn='C2v^7'
hall='P 2ac -2'
case('Pnm21')
num='31:ba-c'
schn='C2v^7'
hall='P 2bc -2bc'
case('P21mn')
num='31:cab'
schn='C2v^7'
hall='P -2ab 2ab'
case('P21nm')
num='31:-cba'
schn='C2v^7'
hall='P -2 2ac'
case('Pn21m')
num='31:bca'
schn='C2v^7'
hall='P -2 -2bc'
case('Pm21n')
num='31:a-cb'
schn='C2v^7'
hall='P -2ab -2'
case('Pba2')
num='32'
schn='C2v^8'
hall='P 2 -2ab'
case('P2cb')
num='32:cab'
schn='C2v^8'
hall='P -2bc 2'
case('Pc2a')
num='32:bca'
schn='C2v^8'
hall='P -2ac -2ac'
case('Pna21')
num='33'
schn='C2v^9'
hall='P 2c -2n'
case('Pbn21')
num='33:ba-c'
schn='C2v^9'
hall='P 2c -2ab'
case('P21nb')
num='33:cab'
schn='C2v^9'
hall='P -2bc 2a'
case('P21cn')
num='33:-cba'
schn='C2v^9'
hall='P -2n 2a'
case('Pc21n')
num='33:bca'
schn='C2v^9'
hall='P -2n -2ac'
case('Pn21a')
num='33:a-cb'
schn='C2v^9'
hall='P -2ac -2n'
case('Pnn2')
num='34'
schn='C2v^10'
hall='P 2 -2n'
case('P2nn')
num='34:cab'
schn='C2v^10'
hall='P -2n 2'
case('Pn2n')
num='34:bca'
schn='C2v^10'
hall='P -2n -2n'
case('Cmm2')
num='35'
schn='C2v^11'
hall='C 2 -2'
case('A2mm')
num='35:cab'
schn='C2v^11'
hall='A -2 2'
case('Bm2m')
num='35:bca'
schn='C2v^11'
hall='B -2 -2'
case('Cmc21')
num='36'
schn='C2v^12'
hall='C 2c -2'
case('Ccm21')
num='36:ba-c'
schn='C2v^12'
hall='C 2c -2c'
case('A21ma')
num='36:cab'
schn='C2v^12'
hall='A -2a 2a'
case('A21am')
num='36:-cba'
schn='C2v^12'
hall='A -2 2a'
case('Bb21m')
num='36:bca'
schn='C2v^12'
hall='B -2 -2b'
case('Bm21b')
num='36:a-cb'
schn='C2v^12'
hall='B -2b -2'
case('Ccc2')
num='37'
schn='C2v^13'
hall='C 2 -2c'
case('A2aa')
num='37:cab'
schn='C2v^13'
hall='A -2a 2'
case('Bb2b')
num='37:bca'
schn='C2v^13'
hall='B -2b -2b'
case('Amm2')
num='38'
schn='C2v^14'
hall='A 2 -2'
case('Bmm2')
num='38:ba-c'
schn='C2v^14'
hall='B 2 -2'
case('B2mm')
num='38:cab'
schn='C2v^14'
hall='B -2 2'
case('C2mm')
num='38:-cba'
schn='C2v^14'
hall='C -2 2'
case('Cm2m')
num='38:bca'
schn='C2v^14'
hall='C -2 -2'
case('Am2m')
num='38:a-cb'
schn='C2v^14'
hall='A -2 -2'
case('Abm2')
num='39'
schn='C2v^15'
hall='A 2 -2c'
case('Bma2')
num='39:ba-c'
schn='C2v^15'
hall='B 2 -2c'
case('B2cm')
num='39:cab'
schn='C2v^15'
hall='B -2c 2'
case('C2mb')
num='39:-cba'
schn='C2v^15'
hall='C -2b 2'
case('Cm2a')
num='39:bca'
schn='C2v^15'
hall='C -2b -2b'
case('Ac2m')
num='39:a-cb'
schn='C2v^15'
hall='A -2c -2c'
case('Ama2')
num='40'
schn='C2v^16'
hall='A 2 -2a'
case('Bbm2')
num='40:ba-c'
schn='C2v^16'
hall='B 2 -2b'
case('B2mb')
num='40:cab'
schn='C2v^16'
hall='B -2b 2'
case('C2cm')
num='40:-cba'
schn='C2v^16'
hall='C -2c 2'
case('Cc2m')
num='40:bca'
schn='C2v^16'
hall='C -2c -2c'
case('Am2a')
num='40:a-cb'
schn='C2v^16'
hall='A -2a -2a'
case('Aba2')
num='41'
schn='C2v^17'
hall='A 2 -2ac'
case('Bba2')
num='41:ba-c'
schn='C2v^17'
hall='B 2 -2bc'
case('B2cb')
num='41:cab'
schn='C2v^17'
hall='B -2bc 2'
case('C2cb')
num='41:-cba'
schn='C2v^17'
hall='C -2bc 2'
case('Cc2a')
num='41:bca'
schn='C2v^17'
hall='C -2bc -2bc'
case('Ac2a')
num='41:a-cb'
schn='C2v^17'
hall='A -2ac -2ac'
case('Fmm2')
num='42'
schn='C2v^18'
hall='F 2 -2'
case('F2mm')
num='42:cab'
schn='C2v^18'
hall='F -2 2'
case('Fm2m')
num='42:bca'
schn='C2v^18'
hall='F -2 -2'
case('Fdd2')
num='43'
schn='C2v^19'
hall='F 2 -2d'
case('F2dd')
num='43:cab'
schn='C2v^19'
hall='F -2d 2'
case('Fd2d')
num='43:bca'
schn='C2v^19'
hall='F -2d -2d'
case('Imm2')
num='44'
schn='C2v^20'
hall='I 2 -2'
case('I2mm')
num='44:cab'
schn='C2v^20'
hall='I -2 2'
case('Im2m')
num='44:bca'
schn='C2v^20'
hall='I -2 -2'
case('Iba2')
num='45'
schn='C2v^21'
hall='I 2 -2c'
case('I2cb')
num='45:cab'
schn='C2v^21'
hall='I -2a 2'
case('Ic2a')
num='45:bca'
schn='C2v^21'
hall='I -2b -2b'
case('Ima2')
num='46'
schn='C2v^22'
hall='I 2 -2a'
case('Ibm2')
num='46:ba-c'
schn='C2v^22'
hall='I 2 -2b'
case('I2mb')
num='46:cab'
schn='C2v^22'
hall='I -2b 2'
case('I2cm')
num='46:-cba'
schn='C2v^22'
hall='I -2c 2'
case('Ic2m')
num='46:bca'
schn='C2v^22'
hall='I -2c -2c'
case('Im2a')
num='46:a-cb'
schn='C2v^22'
hall='I -2a -2a'
case('Pmmm')
num='47'
schn='D2h^1'
hall='-P 2 2'
case('Pnnn:1')
num='48:1'
schn='D2h^2'
hall='P 2 2 -1n'
case('Pnnn:2')
num='48:2'
schn='D2h^2'
hall='-P 2ab 2bc'
case('Pccm')
num='49'
schn='D2h^3'
hall='-P 2 2c'
case('Pmaa')
num='49:cab'
schn='D2h^3'
hall='-P 2a 2'
case('Pbmb')
num='49:bca'
schn='D2h^3'
hall='-P 2b 2b'
case('Pban:1')
num='50:1'
schn='D2h^4'
hall='P 2 2 -1ab'
case('Pban:2')
num='50:2'
schn='D2h^4'
hall='-P 2ab 2b'
case('Pncb:1')
num='50:1cab'
schn='D2h^4'
hall='P 2 2 -1bc'
case('Pncb:2')
num='50:2cab'
schn='D2h^4'
hall='-P 2b 2bc'
case('Pcna:1')
num='50:1bca'
schn='D2h^4'
hall='P 2 2 -1ac'
case('Pcna:2')
num='50:2bca'
schn='D2h^4'
hall='-P 2a 2c'
case('Pmma')
num='51'
schn='D2h^5'
hall='-P 2a 2a'
case('Pmmb')
num='51:ba-c'
schn='D2h^5'
hall='-P 2b 2'
case('Pbmm')
num='51:cab'
schn='D2h^5'
hall='-P 2 2b'
case('Pcmm')
num='51:-cba'
schn='D2h^5'
hall='-P 2c 2c'
case('Pmcm')
num='51:bca'
schn='D2h^5'
hall='-P 2c 2'
case('Pmam')
num='51:a-cb'
schn='D2h^5'
hall='-P 2 2a'
case('Pnna')
num='52'
schn='D2h^6'
hall='-P 2a 2bc'
case('Pnnb')
num='52:ba-c'
schn='D2h^6'
hall='-P 2b 2n'
case('Pbnn')
num='52:cab'
schn='D2h^6'
hall='-P 2n 2b'
case('Pcnn')
num='52:-cba'
schn='D2h^6'
hall='-P 2ab 2c'
case('Pncn')
num='52:bca'
schn='D2h^6'
hall='-P 2ab 2n'
case('Pnan')
num='52:a-cb'
schn='D2h^6'
hall='-P 2n 2bc'
case('Pmna')
num='53'
schn='D2h^7'
hall='-P 2ac 2'
case('Pnmb')
num='53:ba-c'
schn='D2h^7'
hall='-P 2bc 2bc'
case('Pbmn')
num='53:cab'
schn='D2h^7'
hall='-P 2ab 2ab'
case('Pcnm')
num='53:-cba'
schn='D2h^7'
hall='-P 2 2ac'
case('Pncm')
num='53:bca'
schn='D2h^7'
hall='-P 2 2bc'
case('Pman')
num='53:a-cb'
schn='D2h^7'
hall='-P 2ab 2'
case('Pcca')
num='54'
schn='D2h^8'
hall='-P 2a 2ac'
case('Pccb')
num='54:ba-c'
schn='D2h^8'
hall='-P 2b 2c'
case('Pbaa')
num='54:cab'
schn='D2h^8'
hall='-P 2a 2b'
case('Pcaa')
num='54:-cba'
schn='D2h^8'
hall='-P 2ac 2c'
case('Pbcb')
num='54:bca'
schn='D2h^8'
hall='-P 2bc 2b'
case('Pbab')
num='54:a-cb'
schn='D2h^8'
hall='-P 2b 2ab'
case('Pbam')
num='55'
schn='D2h^9'
hall='-P 2 2ab'
case('Pmcb')
num='55:cab'
schn='D2h^9'
hall='-P 2bc 2'
case('Pcma')
num='55:bca'
schn='D2h^9'
hall='-P 2ac 2ac'
case('Pccn')
num='56'
schn='D2h^10'
hall='-P 2ab 2ac'
case('Pnaa')
num='56:cab'
schn='D2h^10'
hall='-P 2ac 2bc'
case('Pbnb')
num='56:bca'
schn='D2h^10'
hall='-P 2bc 2ab'
case('Pbcm')
num='57'
schn='D2h^11'
hall='-P 2c 2b'
case('Pcam')
num='57:ba-c'
schn='D2h^11'
hall='-P 2c 2ac'
case('Pmca')
num='57:cab'
schn='D2h^11'
hall='-P 2ac 2a'
case('Pmab')
num='57:-cba'
schn='D2h^11'
hall='-P 2b 2a'
case('Pbma')
num='57:bca'
schn='D2h^11'
hall='-P 2a 2ab'
case('Pcmb')
num='57:a-cb'
schn='D2h^11'
hall='-P 2bc 2c'
case('Pnnm')
num='58'
schn='D2h^12'
hall='-P 2 2n'
case('Pmnn')
num='58:cab'
schn='D2h^12'
hall='-P 2n 2'
case('Pnmn')
num='58:bca'
schn='D2h^12'
hall='-P 2n 2n'
case('Pmmn:1')
num='59:1'
schn='D2h^13'
hall='P 2 2ab -1ab'
case('Pmmn:2')
num='59:2'
schn='D2h^13'
hall='-P 2ab 2a'
case('Pnmm:1')
num='59:1cab'
schn='D2h^13'
hall='P 2bc 2 -1bc'
case('Pnmm:2')
num='59:2cab'
schn='D2h^13'
hall='-P 2c 2bc'
case('Pmnm:1')
num='59:1bca'
schn='D2h^13'
hall='P 2ac 2ac -1ac'
case('Pmnm:2')
num='59:2bca'
schn='D2h^13'
hall='-P 2c 2a'
case('Pbcn')
num='60'
schn='D2h^14'
hall='-P 2n 2ab'
case('Pcan')
num='60:ba-c'
schn='D2h^14'
hall='-P 2n 2c'
case('Pnca')
num='60:cab'
schn='D2h^14'
hall='-P 2a 2n'
case('Pnab')
num='60:-cba'
schn='D2h^14'
hall='-P 2bc 2n'
case('Pbna')
num='60:bca'
schn='D2h^14'
hall='-P 2ac 2b'
case('Pcnb')
num='60:a-cb'
schn='D2h^14'
hall='-P 2b 2ac'
case('Pbca')
num='61'
schn='D2h^15'
hall='-P 2ac 2ab'
case('Pcab')
num='61:ba-c'
schn='D2h^15'
hall='-P 2bc 2ac'
case('Pnma')
num='62'
schn='D2h^16'
hall='-P 2ac 2n'
case('Pmnb')
num='62:ba-c'
schn='D2h^16'
hall='-P 2bc 2a'
case('Pbnm')
num='62:cab'
schn='D2h^16'
hall='-P 2c 2ab'
case('Pcmn')
num='62:-cba'
schn='D2h^16'
hall='-P 2n 2ac'
case('Pmcn')
num='62:bca'
schn='D2h^16'
hall='-P 2n 2a'
case('Pnam')
num='62:a-cb'
schn='D2h^16'
hall='-P 2c 2n'
case('Cmcm')
num='63'
schn='D2h^17'
hall='-C 2c 2'
case('Ccmm')
num='63:ba-c'
schn='D2h^17'
hall='-C 2c 2c'
case('Amma')
num='63:cab'
schn='D2h^17'
hall='-A 2a 2a'
case('Amam')
num='63:-cba'
schn='D2h^17'
hall='-A 2 2a'
case('Bbmm')
num='63:bca'
schn='D2h^17'
hall='-B 2 2b'
case('Bmmb')
num='63:a-cb'
schn='D2h^17'
hall='-B 2b 2'
case('Cmca')
num='64'
schn='D2h^18'
hall='-C 2bc 2'
case('Ccmb')
num='64:ba-c'
schn='D2h^18'
hall='-C 2bc 2bc'
case('Abma')
num='64:cab'
schn='D2h^18'
hall='-A 2ac 2ac'
case('Acam')
num='64:-cba'
schn='D2h^18'
hall='-A 2 2ac'
case('Bbcm')
num='64:bca'
schn='D2h^18'
hall='-B 2 2bc'
case('Bmab')
num='64:a-cb'
schn='D2h^18'
hall='-B 2bc 2'
case('Cmmm')
num='65'
schn='D2h^19'
hall='-C 2 2'
case('Ammm')
num='65:cab'
schn='D2h^19'
hall='-A 2 2'
case('Bmmm')
num='65:bca'
schn='D2h^19'
hall='-B 2 2'
case('Cccm')
num='66'
schn='D2h^20'
hall='-C 2 2c'
case('Amaa')
num='66:cab'
schn='D2h^20'
hall='-A 2a 2'
case('Bbmb')
num='66:bca'
schn='D2h^20'
hall='-B 2b 2b'
case('Cmma')
num='67'
schn='D2h^21'
hall='-C 2b 2'
case('Cmmb')
num='67:ba-c'
schn='D2h^21'
hall='-C 2b 2b'
case('Abmm')
num='67:cab'
schn='D2h^21'
hall='-A 2c 2c'
case('Acmm')
num='67:-cba'
schn='D2h^21'
hall='-A 2 2c'
case('Bmcm')
num='67:bca'
schn='D2h^21'
hall='-B 2 2c'
case('Bmam')
num='67:a-cb'
schn='D2h^21'
hall='-B 2c 2'
case('Ccca:1')
num='68:1'
schn='D2h^22'
hall='C 2 2 -1bc'
case('Ccca:2')
num='68:2'
schn='D2h^22'
hall='-C 2b 2bc'
case('Cccb:1')
num='68:1ba-c'
schn='D2h^22'
hall='C 2 2 -1bc'
case('Cccb:2')
num='68:2ba-c'
schn='D2h^22'
hall='-C 2b 2c'
case('Abaa:1')
num='68:1cab'
schn='D2h^22'
hall='A 2 2 -1ac'
case('Abaa:2')
num='68:2cab'
schn='D2h^22'
hall='-A 2a 2c'
case('Acaa:1')
num='68:1-cba'
schn='D2h^22'
hall='A 2 2 -1ac'
case('Acaa:2')
num='68:2-cba'
schn='D2h^22'
hall='-A 2ac 2c'
case('Bbcb:1')
num='68:1bca'
schn='D2h^22'
hall='B 2 2 -1bc'
case('Bbcb:2')
num='68:2bca'
schn='D2h^22'
hall='-B 2bc 2b'
case('Bbab:1')
num='68:1a-cb'
schn='D2h^22'
hall='B 2 2 -1bc'
case('Bbab:2')
num='68:2a-cb'
schn='D2h^22'
hall='-B 2b 2bc'
case('Fmmm')
num='69'
schn='D2h^23'
hall='-F 2 2'
case('Fddd:1')
num='70:1'
schn='D2h^24'
hall='F 2 2 -1d'
case('Fddd:2')
num='70:2'
schn='D2h^24'
hall='-F 2uv 2vw'
case('Immm')
num='71'
schn='D2h^25'
hall='-I 2 2'
case('Ibam')
num='72'
schn='D2h^26'
hall='-I 2 2c'
case('Imcb')
num='72:cab'
schn='D2h^26'
hall='-I 2a 2'
case('Icma')
num='72:bca'
schn='D2h^26'
hall='-I 2b 2b'
case('Ibca')
num='73'
schn='D2h^27'
hall='-I 2b 2c'
case('Icab')
num='73:ba-c'
schn='D2h^27'
hall='-I 2a 2b'
case('Imma')
num='74'
schn='D2h^28'
hall='-I 2b 2'
case('Immb')
num='74:ba-c'
schn='D2h^28'
hall='-I 2a 2a'
case('Ibmm')
num='74:cab'
schn='D2h^28'
hall='-I 2c 2c'
case('Icmm')
num='74:-cba'
schn='D2h^28'
hall='-I 2 2b'
case('Imcm')
num='74:bca'
schn='D2h^28'
hall='-I 2 2a'
case('Imam')
num='74:a-cb'
schn='D2h^28'
hall='-I 2c 2'
case('P4')
num='75'
schn='C4^1'
hall='P 4'
case('P41')
num='76'
schn='C4^2'
hall='P 4w'
case('P42')
num='77'
schn='C4^3'
hall='P 4c'
case('P43')
num='78'
schn='C4^4'
hall='P 4cw'
case('I4')
num='79'
schn='C4^5'
hall='I 4'
case('I41')
num='80'
schn='C4^6'
hall='I 4bw'
case('P-4')
num='81'
schn='S4^1'
hall='P -4'
case('I-4')
num='82'
schn='S4^2'
hall='I -4'
case('P4/m')
num='83'
schn='C4h^1'
hall='-P 4'
case('P42/m')
num='84'
schn='C4h^2'
hall='-P 4c'
case('P4/n:1')
num='85:1'
schn='C4h^3'
hall='P 4ab -1ab'
case('P4/n:2')
num='85:2'
schn='C4h^3'
hall='-P 4a'
case('P42/n:1')
num='86:1'
schn='C4h^4'
hall='P 4n -1n'
case('P42/n:2')
num='86:2'
schn='C4h^4'
hall='-P 4bc'
case('I4/m')
num='87'
schn='C4h^5'
hall='-I 4'
case('I41/a:1')
num='88:1'
schn='C4h^6'
hall='I 4bw -1bw'
case('I41/a:2')
num='88:2'
schn='C4h^6'
hall='-I 4ad'
case('P422')
num='89'
schn='D4^1'
hall='P 4 2'
case('P4212')
num='90'
schn='D4^2'
hall='P 4ab 2ab'
case('P4122')
num='91'
schn='D4^3'
hall='P 4w 2c'
case('P41212')
num='92'
schn='D4^4'
hall='P 4abw 2nw'
case('P4222')
num='93'
schn='D4^5'
hall='P 4c 2'
case('P42212')
num='94'
schn='D4^6'
hall='P 4n 2n'
case('P4322')
num='95'
schn='D4^7'
hall='P 4cw 2c'
case('P43212')
num='96'
schn='D4^8'
hall='P 4nw 2abw'
case('I422')
num='97'
schn='D4^9'
hall='I 4 2'
case('I4122')
num='98'
schn='D4^10'
hall='I 4bw 2bw'
case('P4mm')
num='99'
schn='C4v^1'
hall='P 4 -2'
case('P4bm')
num='100'
schn='C4v^2'
hall='P 4 -2ab'
case('P42cm')
num='101'
schn='C4v^3'
hall='P 4c -2c'
case('P42nm')
num='102'
schn='C4v^4'
hall='P 4n -2n'
case('P4cc')
num='103'
schn='C4v^5'
hall='P 4 -2c'
case('P4nc')
num='104'
schn='C4v^6'
hall='P 4 -2n'
case('P42mc')
num='105'
schn='C4v^7'
hall='P 4c -2'
case('P42bc')
num='106'
schn='C4v^8'
hall='P 4c -2ab'
case('I4mm')
num='107'
schn='C4v^9'
hall='I 4 -2'
case('I4cm')
num='108'
schn='C4v^10'
hall='I 4 -2c'
case('I41md')
num='109'
schn='C4v^11'
hall='I 4bw -2'
case('I41cd')
num='110'
schn='C4v^12'
hall='I 4bw -2c'
case('P-42m')
num='111'
schn='D2d^1'
hall='P -4 2'
case('P-42c')
num='112'
schn='D2d^2'
hall='P -4 2c'
case('P-421m')
num='113'
schn='D2d^3'
hall='P -4 2ab'
case('P-421c')
num='114'
schn='D2d^4'
hall='P -4 2n'
case('P-4m2')
num='115'
schn='D2d^5'
hall='P -4 -2'
case('P-4c2')
num='116'
schn='D2d^6'
hall='P -4 -2c'
case('P-4b2')
num='117'
schn='D2d^7'
hall='P -4 -2ab'
case('P-4n2')
num='118'
schn='D2d^8'
hall='P -4 -2n'
case('I-4m2')
num='119'
schn='D2d^9'
hall='I -4 -2'
case('I-4c2')
num='120'
schn='D2d^10'
hall='I -4 -2c'
case('I-42m')
num='121'
schn='D2d^11'
hall='I -4 2'
case('I-42d')
num='122'
schn='D2d^12'
hall='I -4 2bw'
case('P4/mmm')
num='123'
schn='D4h^1'
hall='-P 4 2'
case('P4/mcc')
num='124'
schn='D4h^2'
hall='-P 4 2c'
case('P4/nbm:1')
num='125:1'
schn='D4h^3'
hall='P 4 2 -1ab'
case('P4/nbm:2')
num='125:2'
schn='D4h^3'
hall='-P 4a 2b'
case('P4/nnc:1')
num='126:1'
schn='D4h^4'
hall='P 4 2 -1n'
case('P4/nnc:2')
num='126:2'
schn='D4h^4'
hall='-P 4a 2bc'
case('P4/mbm')
num='127'
schn='D4h^5'
hall='-P 4 2ab'
case('P4/mnc')
num='128'
schn='D4h^6'
hall='-P 4 2n'
case('P4/nmm:1')
num='129:1'
schn='D4h^7'
hall='P 4ab 2ab -1ab'
case('P4/nmm:2')
num='129:2'
schn='D4h^7'
hall='-P 4a 2a'
case('P4/ncc:1')
num='130:1'
schn='D4h^8'
hall='P 4ab 2n -1ab'
case('P4/ncc:2')
num='130:2'
schn='D4h^8'
hall='-P 4a 2ac'
case('P42/mmc')
num='131'
schn='D4h^9'
hall='-P 4c 2'
case('P42/mcm')
num='132'
schn='D4h^10'
hall='-P 4c 2c'
case('P42/nbc:1')
num='133:1'
schn='D4h^11'
hall='P 4n 2c -1n'
case('P42/nbc:2')
num='133:2'
schn='D4h^11'
hall='-P 4ac 2b'
case('P42/nnm:1')
num='134:1'
schn='D4h^12'
hall='P 4n 2 -1n'
case('P42/nnm:2')
num='134:2'
schn='D4h^12'
hall='-P 4ac 2bc'
case('P42/mbc')
num='135'
schn='D4h^13'
hall='-P 4c 2ab'
case('P42/mnm')
num='136'
schn='D4h^14'
hall='-P 4n 2n'
case('P42/nmc:1')
num='137:1'
schn='D4h^15'
hall='P 4n 2n -1n'
case('P42/nmc:2')
num='137:2'
schn='D4h^15'
hall='-P 4ac 2a'
case('P42/ncm:1')
num='138:1'
schn='D4h^16'
hall='P 4n 2ab -1n'
case('P42/ncm:2')
num='138:2'
schn='D4h^16'
hall='-P 4ac 2ac'
case('I4/mmm')
num='139'
schn='D4h^17'
hall='-I 4 2'
case('I4/mcm')
num='140'
schn='D4h^18'
hall='-I 4 2c'
case('I41/amd:1')
num='141:1'
schn='D4h^19'
hall='I 4bw 2bw -1bw'
case('I41/amd:2')
num='141:2'
schn='D4h^19'
hall='-I 4bd 2'
case('I41/acd:1')
num='142:1'
schn='D4h^20'
hall='I 4bw 2aw -1bw'
case('I41/acd:2')
num='142:2'
schn='D4h^20'
hall='-I 4bd 2c'
case('P3')
num='143'
schn='C3^1'
hall='P 3'
case('P31')
num='144'
schn='C3^2'
hall='P 31'
case('P32')
num='145'
schn='C3^3'
hall='P 32'
case('R3:H')
num='146:H'
schn='C3^4'
hall='R 3'
case('R3:R')
num='146:R'
schn='C3^4'
hall='P 3*'
case('P-3')
num='147'
schn='C3i^1'
hall='-P 3'
case('R-3:H')
num='148:H'
schn='C3i^2'
hall='-R 3'
case('R-3:R')
num='148:R'
schn='C3i^2'
hall='-P 3*'
case('P312')
num='149'
schn='D3^1'
hall='P 3 2'
case('P321')
num='150'
schn='D3^2'
hall='P 3 2"'
case('P3112')
num='151'
schn='D3^3'
hall='P 31 2c (0 0 1)'
case('P3121')
num='152'
schn='D3^4'
hall='P 31 2"'
case('P3212')
num='153'
schn='D3^5'
hall='P 32 2c (0 0 -1)'
case('P3221')
num='154'
schn='D3^6'
hall='P 32 2"'
case('R32:H')
num='155:H'
schn='D3^7'
hall='R 3 2"'
case('R32:R')
num='155:R'
schn='D3^7'
hall='P 3* 2'
case('P3m1')
num='156'
schn='C3v^1'
hall='P 3 -2"'
case('P31m')
num='157'
schn='C3v^2'
hall='P 3 -2'
case('P3c1')
num='158'
schn='C3v^3'
hall='P 3 -2"c'
case('P31c')
num='159'
schn='C3v^4'
hall='P 3 -2c'
case('R3m:H')
num='160:H'
schn='C3v^5'
hall='R 3 -2"'
case('R3m:R')
num='160:R'
schn='C3v^5'
hall='P 3* -2'
case('R3c:H')
num='161:H'
schn='C3v^6'
hall='R 3 -2"c'
case('R3c:R')
num='161:R'
schn='C3v^6'
hall='P 3* -2n'
case('P-31m')
num='162'
schn='D3d^1'
hall='-P 3 2'
case('P-31c')
num='163'
schn='D3d^2'
hall='-P 3 2c'
case('P-3m1')
num='164'
schn='D3d^3'
hall='-P 3 2"'
case('P-3c1')
num='165'
schn='D3d^4'
hall='-P 3 2"c'
case('R-3m:H')
num='166:H'
schn='D3d^5'
hall='-R 3 2"'
case('R-3m:R')
num='166:R'
schn='D3d^5'
hall='-P 3* 2'
case('R-3c:H')
num='167:H'
schn='D3d^6'
hall='-R 3 2"c'
case('R-3c:R')
num='167:R'
schn='D3d^6'
hall='-P 3* 2n'
case('P6')
num='168'
schn='C6^1'
hall='P 6'
case('P61')
num='169'
schn='C6^2'
hall='P 61'
case('P65')
num='170'
schn='C6^3'
hall='P 65'
case('P62')
num='171'
schn='C6^4'
hall='P 62'
case('P64')
num='172'
schn='C6^5'
hall='P 64'
case('P63')
num='173'
schn='C6^6'
hall='P 6c'
case('P-6')
num='174'
schn='C3h^1'
hall='P -6'
case('P6/m')
num='175'
schn='C6h^1'
hall='-P 6'
case('P63/m')
num='176'
schn='C6h^2'
hall='-P 6c'
case('P622')
num='177'
schn='D6^1'
hall='P 6 2'
case('P6122')
num='178'
schn='D6^2'
hall='P 61 2 (0 0 -1)'
case('P6522')
num='179'
schn='D6^3'
hall='P 65 2 (0 0 1)'
case('P6222')
num='180'
schn='D6^4'
hall='P 62 2c (0 0 1)'
case('P6422')
num='181'
schn='D6^5'
hall='P 64 2c (0 0 -1)'
case('P6322')
num='182'
schn='D6^6'
hall='P 6c 2c'
case('P6mm')
num='183'
schn='C6v^1'
hall='P 6 -2'
case('P6cc')
num='184'
schn='C6v^2'
hall='P 6 -2c'
case('P63cm')
num='185'
schn='C6v^3'
hall='P 6c -2'
case('P63mc')
num='186'
schn='C6v^4'
hall='P 6c -2c'
case('P-6m2')
num='187'
schn='D3h^1'
hall='P -6 2'
case('P-6c2')
num='188'
schn='D3h^2'
hall='P -6c 2'
case('P-62m')
num='189'
schn='D3h^3'
hall='P -6 -2'
case('P-62c')
num='190'
schn='D3h^4'
hall='P -6c -2c'
case('P6/mmm')
num='191'
schn='D6h^1'
hall='-P 6 2'
case('P6/mcc')
num='192'
schn='D6h^2'
hall='-P 6 2c'
case('P63/mcm')
num='193'
schn='D6h^3'
hall='-P 6c 2'
case('P63/mmc')
num='194'
schn='D6h^4'
hall='-P 6c 2c'
case('P23')
num='195'
schn='T^1'
hall='P 2 2 3'
case('F23')
num='196'
schn='T^2'
hall='F 2 2 3'
case('I23')
num='197'
schn='T^3'
hall='I 2 2 3'
case('P213')
num='198'
schn='T^4'
hall='P 2ac 2ab 3'
case('I213')
num='199'
schn='T^5'
hall='I 2b 2c 3'
case('Pm-3')
num='200'
schn='Th^1'
hall='-P 2 2 3'
case('Pn-3:1')
num='201:1'
schn='Th^2'
hall='P 2 2 3 -1n'
case('Pn-3:2')
num='201:2'
schn='Th^2'
hall='-P 2ab 2bc 3'
case('Fm-3')
num='202'
schn='Th^3'
hall='-F 2 2 3'
case('Fd-3:1')
num='203:1'
schn='Th^4'
hall='F 2 2 3 -1d'
case('Fd-3:2')
num='203:2'
schn='Th^4'
hall='-F 2uv 2vw 3'
case('Im-3')
num='204'
schn='Th^5'
hall='-I 2 2 3'
case('Pa-3')
num='205'
schn='Th^6'
hall='-P 2ac 2ab 3'
case('Ia-3')
num='206'
schn='Th^7'
hall='-I 2b 2c 3'
case('P432')
num='207'
schn='O^1'
hall='P 4 2 3'
case('P4232')
num='208'
schn='O^2'
hall='P 4n 2 3'
case('F432')
num='209'
schn='O^3'
hall='F 4 2 3'
case('F4132')
num='210'
schn='O^4'
hall='F 4d 2 3'
case('I432')
num='211'
schn='O^5'
hall='I 4 2 3'
case('P4332')
num='212'
schn='O^6'
hall='P 4acd 2ab 3'
case('P4132')
num='213'
schn='O^7'
hall='P 4bd 2ab 3'
case('I4132')
num='214'
schn='O^8'
hall='I 4bd 2c 3'
case('P-43m')
num='215'
schn='Td^1'
hall='P -4 2 3'
case('F-43m')
num='216'
schn='Td^2'
hall='F -4 2 3'
case('I-43m')
num='217'
schn='Td^3'
hall='I -4 2 3'
case('P-43n')
num='218'
schn='Td^4'
hall='P -4n 2 3'
case('F-43c')
num='219'
schn='Td^5'
hall='F -4c 2 3'
case('I-43d')
num='220'
schn='Td^6'
hall='I -4bd 2c 3'
case('Pm-3m')
num='221'
schn='Oh^1'
hall='-P 4 2 3'
case('Pn-3n:1')
num='222:1'
schn='Oh^2'
hall='P 4 2 3 -1n'
case('Pn-3n:2')
num='222:2'
schn='Oh^2'
hall='-P 4a 2bc 3'
case('Pm-3n')
num='223'
schn='Oh^3'
hall='-P 4n 2 3'
case('Pn-3m:1')
num='224:1'
schn='Oh^4'
hall='P 4n 2 3 -1n'
case('Pn-3m:2')
num='224:2'
schn='Oh^4'
hall='-P 4bc 2bc 3'
case('Fm-3m')
num='225'
schn='Oh^5'
hall='-F 4 2 3'
case('Fm-3c')
num='226'
schn='Oh^6'
hall='-F 4c 2 3'
case('Fd-3m:1')
num='227:1'
schn='Oh^7'
hall='F 4d 2 3 -1d'
case('Fd-3m:2')
num='227:2'
schn='Oh^7'
hall='-F 4vw 2vw 3'
case('Fd-3c:1')
num='228:1'
schn='Oh^8'
hall='F 4d 2 3 -1cd'
case('Fd-3c:2')
num='228:2'
schn='Oh^8'
hall='-F 4cvw 2vw 3'
case('Im-3m')
num='229'
schn='Oh^9'
hall='-I 4 2 3'
case('Ia-3d')
num='230'
schn='Oh^10'
hall='-I 4bd 2c 3'
case default
write(*,*)
write(*,'("Error(sgsymb): Hermann-Mauguin symbol ''",A,"'' not found")') &
trim(adjustl(hrmg))
write(*,*)
stop
end select
return
end subroutine
!EOC
elk-7.2.42/src/spacegroup/PaxHeaders.21776/writegeom.f90 0000644 0000000 0000000 00000000127 14061636515 017420 x ustar 00 29 mtime=1623670093.53810377
29 atime=1623670093.53810377
29 ctime=1623670093.53810377
elk-7.2.42/src/spacegroup/writegeom.f90 0000644 0025044 0025044 00000003346 14061636515 021457 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2006 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine writegeom
use modmain
implicit none
! local variables
integer is,ia,ip
open(50,file='GEOMETRY.OUT',action='WRITE',form='FORMATTED')
write(50,*)
write(50,'("! Atomic positions generated by spacegroup version ",&
&I1.1,".",I1.1,".",I2.2)') version
write(50,'("! Hermann-Mauguin symbol : ",A)') trim(hrmg)
write(50,'("! Hall symbol : ",A)') trim(hall)
write(50,'("! Schoenflies symbol : ",A)') trim(schn)
write(50,'("! space group number : ",A)') trim(num)
write(50,'("! lattice constants (a,b,c) : ",3G18.10)') a,b,c
write(50,'("! angles in degrees (bc,ac,ab) : ",3G18.10)') bc,ac,ab
write(50,'("! number of conventional unit cells : ",3I4)') ncell
write(50,'("! reduction to primitive cell : ",L1)') primcell
write(50,'("! Wyckoff positions :")')
do is=1,nspecies
write(50,'("! species : ",I4,", ",A)') is,trim(spsymb(is))
do ip=1,nwpos(is)
write(50,'("! ",3G18.10)') wpos(:,ip,is)
end do
end do
write(50,*)
write(50,'("avec")')
write(50,'(3G18.10)') avec(:,1)
write(50,'(3G18.10)') avec(:,2)
write(50,'(3G18.10)') avec(:,3)
write(50,*)
write(50,'("atoms")')
write(50,'(I4,T40," : nspecies")') nspecies
do is=1,nspecies
write(50,'("''",A,"''",T40," : spfname")') trim(spsymb(is))//'.in'
write(50,'(I4,T40," : natoms; atposl, bfcmt below")') natoms(is)
do ia=1,natoms(is)
write(50,'(3F14.8," ",3F12.8)') atposl(:,ia,is),bfcmt0(:,ia,is)
end do
end do
close(50)
write(*,*)
write(*,'("Info(writegeom):")')
write(*,'(" Elk lattice vectors and atomic positions written to GEOMETRY.OUT")')
return
end subroutine
elk-7.2.42/src/PaxHeaders.21776/modmain.f90 0000644 0000000 0000000 00000000132 14061636516 014667 x ustar 00 30 mtime=1623670094.832102569
30 atime=1623670093.546103763
30 ctime=1623670094.832102569
elk-7.2.42/src/modmain.f90 0000644 0025044 0025044 00000120145 14061636516 016727 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2009 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modmain
!----------------------------!
! lattice parameters !
!----------------------------!
! lattice vectors stored column-wise
real(8) avec(3,3)
! magnitude of random displacements added to lattice vectors
real(8) rndavec
! inverse of lattice vector matrix
real(8) ainv(3,3)
! reciprocal lattice vectors
real(8) bvec(3,3)
! inverse of reciprocal lattice vector matrix
real(8) binv(3,3)
! unit cell volume
real(8) omega
! Brillouin zone volume
real(8) omegabz
! any vector with length less than epslat is considered zero
real(8) epslat
!--------------------------!
! atomic variables !
!--------------------------!
! maximum allowed species
integer, parameter :: maxspecies=8
! maximum allowed atoms per species
integer, parameter :: maxatoms=200
! number of species
integer nspecies
! number of atoms for each species
integer natoms(maxspecies)
! maximum number of atoms over all the species
integer natmmax
! total number of atoms
integer natmtot
! index to atoms and species
integer idxas(maxatoms,maxspecies)
! inverse atoms and species indices
integer idxis(maxatoms*maxspecies)
integer idxia(maxatoms*maxspecies)
! molecule is .true. is the system is an isolated molecule
logical molecule
! primcell is .true. if primitive unit cell is to be found automatically
logical primcell
! atomic positions in lattice coordinates
real(8) atposl(3,maxatoms,maxspecies)
! atomic positions in Cartesian coordinates
real(8) atposc(3,maxatoms,maxspecies)
! magnitude of random displacements added to the atomic positions
real(8) rndatposc
! tdatpos is .true. if small amplitude displacements are to be included when
! calculating the Coulomb potential
logical :: tdatpos=.false.
! trddatpos is .true. if the small amplitude displacements and velocities are to
! be read from file
logical :: trddatpos=.false.
! small amplitude atomic displacements and velocities
real(8) datposc(3,0:1,maxatoms,maxspecies)
!----------------------------------!
! atomic species variables !
!----------------------------------!
! species files path
character(256) sppath
! species filenames
character(256) spfname(maxspecies)
! species name
character(256) spname(maxspecies)
! species symbol
character(256) spsymb(maxspecies)
! species nuclear charge
real(8) spzn(maxspecies)
! ptnucl is .true. if the nuclei are to be treated as point charges, if .false.
! the nuclei have a finite spherical distribution
logical ptnucl
! nuclear radius
real(8) rnucl(maxspecies)
! nuclear volume
real(8) volnucl(maxspecies)
! number of radial mesh points to nuclear radius
integer nrnucl(maxspecies)
! nuclear Coulomb potential
real(8), allocatable :: vcln(:,:)
! species electronic charge
real(8) spze(maxspecies)
! species mass
real(8) spmass(maxspecies)
! smallest radial point for each species
real(8) rminsp(maxspecies)
! effective infinity for species
real(8) rmaxsp(maxspecies)
! number of radial points to effective infinity for each species
integer nrsp(maxspecies)
! maximum nrsp over all the species
integer nrspmax
! maximum allowed states for each species
integer, parameter :: maxstsp=40
! number of states for each species
integer nstsp(maxspecies)
! maximum nstsp over all the species
integer nstspmax
! core-valence cut-off energy for species file generation
real(8) ecvcut
! semi-core-valence cut-off energy for species file generation
real(8) esccut
! state principle quantum number for each species
integer nsp(maxstsp,maxspecies)
! state l value for each species
integer lsp(maxstsp,maxspecies)
! state k value for each species
integer ksp(maxstsp,maxspecies)
! spcore is .true. if species state is core
logical spcore(maxstsp,maxspecies)
! total number of core states
integer nstcr
! state eigenvalue for each species
real(8) evalsp(maxstsp,maxspecies)
! state occupancy for each species
real(8) occsp(maxstsp,maxspecies)
! species radial mesh to effective infinity
real(8), allocatable :: rsp(:,:)
! species charge density
real(8), allocatable :: rhosp(:,:)
! species self-consistent potential
real(8), allocatable :: vrsp(:,:)
! exchange-correlation type for atomic species (the converged ground-state of
! the crystal does not depend on this choice)
integer xctsp(3)
!---------------------------------------------------------------!
! muffin-tin radial mesh and angular momentum variables !
!---------------------------------------------------------------!
! scale factor for number of muffin-tin points
real(8) nrmtscf
! number of muffin-tin radial points for each species
integer nrmt(maxspecies)
! maximum nrmt over all the species
integer nrmtmax
! optional default muffin-tin radius for all atoms
real(8) rmtall
! minimum allowed distance between muffin-tin surfaces
real(8) rmtdelta
! muffin-tin radii
real(8) rmt(maxspecies)
! total muffin-tin volume
real(8) omegamt
! radial step length for coarse mesh
integer lradstp
! number of coarse radial mesh points
integer nrcmt(maxspecies)
! maximum nrcmt over all the species
integer nrcmtmax
! coarse muffin-tin radial mesh
real(8), allocatable :: rcmt(:,:)
! r^l on fine radial mesh
real(8), allocatable :: rlmt(:,:,:)
! r^l on coarse radial mesh
real(8), allocatable :: rlcmt(:,:,:)
! weights for spline integration on fine radial mesh
real(8), allocatable :: wrmt(:,:)
! weights for spline partial integration on fine radial mesh
real(8), allocatable :: wprmt(:,:,:)
! weights for spline coefficients on fine radial mesh
real(8), allocatable :: wcrmt(:,:,:)
! weights for spline integration on coarse radial mesh
real(8), allocatable :: wrcmt(:,:)
! weights for spline partial integration on coarse radial mesh
real(8), allocatable :: wprcmt(:,:,:)
! weights for spline coefficients on coarse radial mesh
real(8), allocatable :: wcrcmt(:,:,:)
! maximum allowable angular momentum for augmented plane waves
integer, parameter :: maxlapw=30
! maximum angular momentum for augmented plane waves
integer lmaxapw
! (lmaxapw+1)^2
integer lmmaxapw
! maximum angular momentum on the outer part of the muffin-tin
integer lmaxo
! (lmaxo+1)^2
integer lmmaxo
! maximum angular momentum on the inner part of the muffin-tin
integer lmaxi
! (lmaxi+1)^2
integer lmmaxi
! fraction of muffin-tin radius which constitutes the inner part
real(8) fracinr
! number of fine/coarse radial points on the inner part of the muffin-tin
integer nrmti(maxspecies),nrcmti(maxspecies)
! number of fine/coarse points in packed muffin-tins
integer npmti(maxspecies),npmt(maxspecies)
integer npcmti(maxspecies),npcmt(maxspecies)
! maximum number of points over all packed muffin-tins
integer npmtmax,npcmtmax
!--------------------------------!
! spin related variables !
!--------------------------------!
! spinpol is .true. for spin-polarised calculations
logical spinpol
! spinorb is .true. for spin-orbit coupling
logical spinorb
! scale factor of spin-orbit coupling term in Hamiltonian
real(8) socscf
! dimension of magnetisation and magnetic vector fields (1 or 3)
integer ndmag
! ncmag is .true. if the magnetisation is non-collinear, i.e. when ndmag = 3
logical ncmag
! if cmagz is .true. then collinear magnetism along the z-axis is enforced
logical cmagz
! spcpl is .true. if the up and down spins are coupled
logical spcpl
! fixed spin moment type
! 0 : none
! 1 (-1) : total moment (direction)
! 2 (-2) : individual muffin-tin moments (direction)
! 3 (-3) : total and muffin-tin moments (direction)
integer fsmtype
! fixed total spin magnetic moment
real(8) momfix(3)
! fixed spin moment global effective field in Cartesian coordinates
real(8) bfsmc(3)
! muffin-tin fixed spin moments
real(8) mommtfix(3,maxatoms,maxspecies)
! muffin-tin fixed spin moment effective fields in Cartesian coordinates
real(8), allocatable :: bfsmcmt(:,:)
! fixed spin moment field step size
real(8) taufsm
! second-variational spinor dimension (1 or 2)
integer nspinor
! global external magnetic field in Cartesian coordinates
real(8) bfieldc(3)
! initial field
real(8) bfieldc0(3)
! external magnetic field in each muffin-tin in Cartesian coordinates
real(8) bfcmt(3,maxatoms,maxspecies)
! initial field as read in from input file
real(8) bfcmt0(3,maxatoms,maxspecies)
! magnitude of random vectors added to muffin-tin fields
real(8) rndbfcmt
! external magnetic fields are multiplied by reducebf after each s.c. loop
real(8) reducebf
! spinsprl is .true. if a spin-spiral is to be calculated
logical spinsprl
! ssdph is .true. if the muffin-tin spin-spiral magnetisation is de-phased
logical ssdph
! spin-spiral phase factor for each atom
complex(8), allocatable :: zqss(:)
! number of spin-dependent first-variational functions per state
integer nspnfv
! map from second- to first-variational spin index
integer jspnfv(2)
! spin-spiral q-vector in lattice coordinates
real(8) vqlss(3)
! spin-spiral q-vector in Cartesian coordinates
real(8) vqcss(3)
! current q-point in spin-spiral supercell calculation
integer iqss
! number of primitive unit cells in spin-spiral supercell
integer nscss
! number of fixed spin direction points on the sphere for finding the magnetic
! anisotropy energy (MAE)
integer npmae0,npmae
! (theta,phi) coordinates for each MAE direction
real(8), allocatable :: tpmae(:,:)
!---------------------------------------------!
! electric field and vector potential !
!---------------------------------------------!
! tefield is .true. if a polarising constant electric field is applied
logical tefield
! electric field vector in Cartesian coordinates
real(8) efieldc(3)
! electric field vector in lattice coordinates
real(8) efieldl(3)
! tafield is .true. if a constant vector potential is applied
logical tafield
! vector potential A-field which couples to paramagnetic current
real(8) afieldc(3)
! A-field in lattice coordinates
real(8) afieldl(3)
!----------------------------!
! symmetry variables !
!----------------------------!
! type of symmetry allowed for the crystal
! 0 : only the identity element is used
! 1 : full symmetry group is used
! 2 : only symmorphic symmetries are allowed
integer symtype
! number of Bravais lattice point group symmetries
integer nsymlat
! Bravais lattice point group symmetries
integer symlat(3,3,48)
! determinants of lattice symmetry matrices (1 or -1)
integer symlatd(48)
! index to inverses of the lattice symmetries
integer isymlat(48)
! lattice point group symmetries in Cartesian coordinates
real(8) symlatc(3,3,48)
! tshift is .true. if atomic basis is allowed to be shifted
logical tshift
! tsyminv is .true. if the crystal has inversion symmetry
logical tsyminv
! maximum of symmetries allowed
integer, parameter :: maxsymcrys=192
! number of crystal symmetries
integer nsymcrys
! crystal symmetry translation vector in lattice and Cartesian coordinates
real(8) vtlsymc(3,maxsymcrys)
real(8) vtcsymc(3,maxsymcrys)
! tv0symc is .true. if the translation vector is zero
logical tv0symc(maxsymcrys)
! spatial rotation element in lattice point group for each crystal symmetry
integer lsplsymc(maxsymcrys)
! global spin rotation element in lattice point group for each crystal symmetry
integer lspnsymc(maxsymcrys)
! equivalent atom index for each crystal symmetry
integer, allocatable :: ieqatom(:,:,:)
! eqatoms(ia,ja,is) is .true. if atoms ia and ja are equivalent
logical, allocatable :: eqatoms(:,:,:)
! number of site symmetries
integer, allocatable :: nsymsite(:)
! site symmetry spatial rotation element in lattice point group
integer, allocatable :: lsplsyms(:,:)
! site symmetry global spin rotation element in lattice point group
integer, allocatable :: lspnsyms(:,:)
!----------------------------!
! G-vector variables !
!----------------------------!
! G-vector cut-off for interstitial potential and density
real(8) gmaxvr
! G-vector grid sizes
integer ngridg(3)
! G-vector grid sizes for coarse grid (G < 2*gkmax)
integer ngdgc(3)
! total number of G-vectors
integer ngtot
! total number of G-vectors for coarse grid (G < 2*gkmax)
integer ngtc
! integer grid intervals for each direction
integer intgv(2,3)
! number of G-vectors with G < gmaxvr
integer ngvec
! number of G-vectors for coarse grid (G < 2*gkmax)
integer ngvc
! G-vector integer coordinates (i1,i2,i3)
integer, allocatable :: ivg(:,:)
! map from (i1,i2,i3) to G-vector index
integer, allocatable :: ivgig(:,:,:)
! map from G-vector index to FFT array
integer, allocatable :: igfft(:)
! map from G-vector index to FFT array for coarse grid (G < 2*gkmax)
integer, allocatable :: igfc(:)
! G-vectors in Cartesian coordinates
real(8), allocatable :: vgc(:,:)
! length of G-vectors
real(8), allocatable :: gc(:)
! Coulomb Green's function in G-space = 4 pi / G^2
real(8), allocatable :: gclg(:)
! spherical Bessel functions j_l(|G|R_mt)
real(8), allocatable :: jlgrmt(:,:,:)
! spherical harmonics of the G-vectors
complex(8), allocatable :: ylmg(:,:)
! structure factors for the G-vectors
complex(8), allocatable :: sfacg(:,:)
! smooth step function form factors for all species and G-vectors
real(8), allocatable :: ffacg(:,:)
! characteristic function in G-space: 0 inside the muffin-tins and 1 outside
complex(8), allocatable :: cfunig(:)
! characteristic function in real-space: 0 inside the muffin-tins and 1 outside
real(8), allocatable :: cfunir(:)
! characteristic function in real-space for coarse grid (G < 2*gkmax)
real(8), allocatable :: cfrc(:)
!---------------------------!
! k-point variables !
!---------------------------!
! autokpt is .true. if the k-point set is determined automatically
logical autokpt
! radius of sphere used to determine k-point density when autokpt is .true.
real(8) radkpt
! k-point grid sizes
integer ngridk(3)
! k-point offset
real(8) vkloff(3)
! type of reduction to perform on k-point set
! 0 : no reduction
! 1 : reduce with full crystal symmetry group
! 2 : reduce with symmorphic symmetries only
integer reducek
! number of point group symmetries used for k-point reduction
integer nsymkpt
! point group symmetry matrices used for k-point reduction
integer symkpt(3,3,48)
! total number of reduced k-points
integer nkpt
! total number of non-reduced k-points
integer nkptnr
! locations of k-points on integer grid
integer, allocatable :: ivk(:,:)
! map from integer grid to reduced k-point index
integer, allocatable :: ivkik(:,:,:)
! map from integer grid to non-reduced k-point index
integer, allocatable :: ivkiknr(:,:,:)
! k-points in lattice coordinates
real(8), allocatable :: vkl(:,:)
! k-points in Cartesian coordinates
real(8), allocatable :: vkc(:,:)
! reduced k-point weights
real(8), allocatable :: wkpt(:)
! weight of each non-reduced k-point
real(8) wkptnr
! k-point at which to determine effective mass tensor
real(8) vklem(3)
! displacement size for computing the effective mass tensor
real(8) deltaem
! number of displacements in each direction
integer ndspem
! number of k-points subdivision used for calculating the polarisation phase
integer nkspolar
!------------------------------!
! G+k-vector variables !
!------------------------------!
! species for which the muffin-tin radius will be used for calculating gkmax
integer isgkmax
! smallest muffin-tin radius times gkmax
real(8) rgkmax
! maximum |G+k| cut-off for APW functions
real(8) gkmax
! number of G+k-vectors for augmented plane waves
integer, allocatable :: ngk(:,:)
! maximum number of G+k-vectors over all k-points
integer ngkmax
! index from G+k-vectors to G-vectors
integer, allocatable :: igkig(:,:,:)
! G+k-vectors in lattice coordinates
real(8), allocatable :: vgkl(:,:,:,:)
! G+k-vectors in Cartesian coordinates
real(8), allocatable :: vgkc(:,:,:,:)
! length of G+k-vectors
real(8), allocatable :: gkc(:,:,:)
! structure factors for the G+k-vectors
complex(8), allocatable :: sfacgk(:,:,:,:)
!---------------------------!
! q-point variables !
!---------------------------!
! q-point grid sizes
integer ngridq(3)
! integer grid intervals for the q-points
integer intq(2,3)
! type of reduction to perform on q-point set (see reducek)
integer reduceq
! number of point group symmetries used for q-point reduction
integer nsymqpt
! point group symmetry matrices used for q-point reduction
integer symqpt(3,3,48)
! total number of reduced q-points
integer nqpt
! total number of non-reduced q-points
integer nqptnr
! locations of q-points on integer grid
integer, allocatable :: ivq(:,:)
! map from integer grid to reduced index
integer, allocatable :: ivqiq(:,:,:)
! map from integer grid to non-reduced index
integer, allocatable :: ivqiqnr(:,:,:)
! map from q-vector index to complex-complex FFT array
integer, allocatable :: iqfft(:)
! number of complex FFT elements for real-complex transforms
integer nfqrz
! map from q-point index to real-complex FFT index
integer, allocatable :: ifqrz(:)
! map from real-complex FFT index to q-point index
integer, allocatable :: iqrzf(:)
! q-points in lattice coordinates
real(8), allocatable :: vql(:,:)
! q-points in Cartesian coordinates
real(8), allocatable :: vqc(:,:)
! q-point weights
real(8), allocatable :: wqpt(:)
! weight for each non-reduced q-point
real(8) wqptnr
! regularised Coulomb Green's function in q-space
real(8), allocatable :: gclq(:)
! if t0gclq0 is .true. then the Coulomb Green's function at q = 0 is set to zero
logical t0gclq0
!-----------------------------------------------------!
! spherical harmonic transform (SHT) matrices !
!-----------------------------------------------------!
! trotsht is .true. if the spherical cover used for the SHT is to be rotated
logical :: trotsht=.false.
! spherical cover rotation matrix
real(8) rotsht(3,3)
! real backward SHT matrix for lmaxi
real(8), allocatable :: rbshti(:,:)
! real forward SHT matrix for lmaxi
real(8), allocatable :: rfshti(:,:)
! real backward SHT matrix for lmaxo
real(8), allocatable :: rbshto(:,:)
! real forward SHT matrix for lmaxo
real(8), allocatable :: rfshto(:,:)
! complex backward SHT matrix for lmaxi
complex(8), allocatable :: zbshti(:,:)
! complex forward SHT matrix for lmaxi
complex(8), allocatable :: zfshti(:,:)
! complex backward SHT matrix for lmaxo
complex(8), allocatable :: zbshto(:,:)
! complex forward SHT matrix for lmaxo
complex(8), allocatable :: zfshto(:,:)
!---------------------------------------------------------------!
! density, potential and exchange-correlation variables !
!---------------------------------------------------------------!
! exchange-correlation functional type
integer xctype(3)
! exchange-correlation functional description
character(512) xcdescr
! exchange-correlation functional spin requirement
integer xcspin
! exchange-correlation functional density gradient requirement
integer xcgrad
! small constant used to stabilise non-collinear GGA
real(8) dncgga
! muffin-tin and interstitial charge density
real(8), allocatable :: rhomt(:,:),rhoir(:)
! trhonorm is .true. if the density is to be normalised after every iteration
logical trhonorm
! muffin-tin and interstitial magnetisation vector field
real(8), allocatable :: magmt(:,:,:),magir(:,:)
! tjr is .true. if the current density j(r) is to be calculated
logical tjr
! muffin-tin and interstitial gauge-invariant current density vector field
real(8), allocatable :: jrmt(:,:,:),jrir(:,:)
! amount of smoothing to be applied to the exchange-correlation potentials and
! magnetic field
integer msmooth
! muffin-tin and interstitial Coulomb potential
real(8), allocatable :: vclmt(:,:),vclir(:)
! Poisson solver pseudocharge density constant
integer npsd
! lmaxo+npsd+1
integer lnpsd
! muffin-tin and interstitial exchange energy density
real(8), allocatable :: exmt(:,:),exir(:)
! muffin-tin and interstitial correlation energy density
real(8), allocatable :: ecmt(:,:),ecir(:)
! muffin-tin and interstitial exchange-correlation potential
real(8), allocatable :: vxcmt(:,:),vxcir(:)
! muffin-tin and interstitial exchange-correlation magnetic field
real(8), allocatable :: bxcmt(:,:,:),bxcir(:,:)
! muffin-tin and interstitial magnetic dipole field
real(8), allocatable :: bdmt(:,:,:),bdir(:,:)
! tbdip is .true. if the spin and current dipole fields are to be added to the
! Kohn-Sham magnetic field
logical tbdip
! combined target array for vsmt, vsir, bsmt and bsir
real(8), allocatable, target :: vsbs(:)
! muffin-tin and interstitial Kohn-Sham effective potential
real(8), pointer :: vsmt(:,:),vsir(:)
! muffin-tin Kohn-Sham effective magnetic field in spherical coordinates and on
! a coarse radial mesh
real(8), pointer :: bsmt(:,:,:)
! interstitial Kohn-Sham effective magnetic field
real(8), pointer :: bsir(:,:)
! G-space interstitial Kohn-Sham effective potential
complex(8), allocatable :: vsig(:)
! nosource is .true. if the field is to be made source-free
logical nosource
! tssxc is .true. if scaled spin exchange-correlation is to be used
logical tssxc
! spin exchange-correlation scaling factor
real(8) sxcscf
! spin-orbit coupling radial function
real(8), allocatable :: socfr(:,:)
! kinetic energy density
real(8), allocatable :: taumt(:,:,:),tauir(:,:)
! core kinetic energy density
real(8), allocatable :: taucr(:,:,:)
! taudft is .true. if meta-GGA is to be treated as a meta-GGA functional
logical taudft
! meta-GGA exchange-correlation potential
real(8), allocatable :: wxcmt(:,:),wxcir(:)
! meta-GGA Kohn-Sham potential
real(8), allocatable :: wsmt(:,:),wsir(:)
! Tran-Blaha '09 constant c [Phys. Rev. Lett. 102, 226401 (2009)]
real(8) c_tb09
! tc_tb09 is .true. if the Tran-Blaha constant has been read in
logical tc_tb09
! if trdstate is .true. the density and potential can be read from STATE.OUT
logical :: trdstate=.false.
! temperature in degrees Kelvin
real(8) tempk
!--------------------------!
! mixing variables !
!--------------------------!
! type of mixing to use for the potential
integer mixtype
! mixing type description
character(256) mixdescr
! adaptive mixing parameters (formerly beta0 and betamax)
real(8) amixpm(2)
! subspace dimension for Broyden mixing
integer mixsdb
! Broyden mixing parameters alpha and w0
real(8) broydpm(2)
!----------------------------------------------!
! charge, moment and current variables !
!----------------------------------------------!
! tolerance for error in total charge
real(8) epschg
! total nuclear charge
real(8) chgzn
! core charges
real(8) chgcr(maxspecies)
! total core charge
real(8) chgcrtot
! core leakage charge
real(8), allocatable :: chgcrlk(:)
! total valence charge
real(8) chgval
! excess charge
real(8) chgexs
! total charge
real(8) chgtot
! calculated total charge
real(8) chgcalc
! interstitial region charge
real(8) chgir
! muffin-tin charges
real(8), allocatable :: chgmt(:)
! total muffin-tin charge
real(8) chgmttot
! effective Wigner radius
real(8) rwigner
! total moment
real(8) momtot(3)
! total moment magnitude
real(8) momtotm
! interstitial region moment
real(8) momir(3)
! muffin-tin moments
real(8), allocatable :: mommt(:,:)
! total muffin-tin moment
real(8) mommttot(3)
! total gauge-invariant current and its magnitude
real(8) jtot(3),jtotm
!-----------------------------------------!
! APW and local-orbital variables !
!-----------------------------------------!
! energy step used for numerical calculation of energy derivatives
real(8) deapwlo
! maximum allowable APW order
integer, parameter :: maxapword=4
! APW order
integer apword(0:maxlapw,maxspecies)
! maximum of apword over all angular momenta and species
integer apwordmax
! total number of APW coefficients (l, m and order) for each species
integer lmoapw(maxspecies)
! polynomial order used for APW radial derivatives
integer npapw
! APW initial linearisation energies
real(8) apwe0(maxapword,0:maxlapw,maxspecies)
! APW linearisation energies
real(8), allocatable :: apwe(:,:,:)
! APW derivative order
integer apwdm(maxapword,0:maxlapw,maxspecies)
! apwve is .true. if the linearisation energies are allowed to vary
logical apwve(maxapword,0:maxlapw,maxspecies)
! APW radial functions
real(8), allocatable :: apwfr(:,:,:,:,:)
! derivate of radial functions at the muffin-tin surface
real(8), allocatable :: apwdfr(:,:,:)
! maximum number of local-orbitals
integer, parameter :: maxlorb=200
! maximum allowable local-orbital order
integer, parameter :: maxlorbord=5
! number of local-orbitals
integer nlorb(maxspecies)
! maximum nlorb over all species
integer nlomax
! total number of local-orbitals
integer nlotot
! local-orbital order
integer lorbord(maxlorb,maxspecies)
! maximum lorbord over all species
integer lorbordmax
! polynomial order used for local-orbital radial derivatives
integer nplorb
! local-orbital angular momentum
integer lorbl(maxlorb,maxspecies)
! maximum lorbl over all species
integer lolmax
! (lolmax+1)^2
integer lolmmax
! local-orbital initial energies
real(8) lorbe0(maxlorbord,maxlorb,maxspecies)
! local-orbital energies
real(8), allocatable :: lorbe(:,:,:)
! local-orbital derivative order
integer lorbdm(maxlorbord,maxlorb,maxspecies)
! lorbve is .true. if the linearisation energies are allowed to vary
logical lorbve(maxlorbord,maxlorb,maxspecies)
! local-orbital radial functions
real(8), allocatable :: lofr(:,:,:,:)
! band energy search tolerance
real(8) epsband
! maximum allowed change in energy during band energy search; enforced only if
! default energy is less than zero
real(8) demaxbnd
! minimum default linearisation energy over all APWs and local-orbitals
real(8) e0min
! if autolinengy is .true. then the fixed linearisation energies are set to the
! Fermi energy minus dlefe
logical autolinengy
! difference between linearisation and Fermi energies when autolinengy is .true.
real(8) dlefe
! lorbcnd is .true. if conduction state local-orbitals should be added
logical lorbcnd
! conduction state local-orbital order
integer lorbordc
! excess order of the APW and local-orbital functions
integer nxoapwlo
! excess local orbitals
integer nxlo
!-------------------------------------------!
! overlap and Hamiltonian variables !
!-------------------------------------------!
! overlap and Hamiltonian matrices sizes at each k-point
integer, allocatable :: nmat(:,:)
! maximum nmat over all k-points
integer nmatmax
! index to the position of the local-orbitals in the H and O matrices
integer, allocatable :: idxlo(:,:,:)
! APW-local-orbital overlap integrals
real(8), allocatable :: oalo(:,:,:)
! local-orbital-local-orbital overlap integrals
real(8), allocatable :: ololo(:,:,:)
! APW-APW Hamiltonian integrals
real(8), allocatable :: haa(:,:,:,:,:,:)
! local-orbital-APW Hamiltonian integrals
real(8), allocatable :: hloa(:,:,:,:,:)
! local-orbital-local-orbital Hamiltonian integrals
real(8), allocatable :: hlolo(:,:,:,:)
! complex Gaunt coefficient array
complex(8), allocatable :: gntyry(:,:,:)
! tefvr is .true. if the first-variational eigenvalue equation is to be solved
! as a real symmetric problem
logical tefvr
! tefvit is .true. if the first-variational eigenvalue equation is to be solved
! iteratively
logical tefvit
! minimum and maximum allowed number of eigenvalue equation iterations
integer minitefv,maxitefv
! eigenvalue mixing parameter for iterative solver
real(8) befvit
! iterative solver convergence tolerance
real(8) epsefvit
!--------------------------------------------!
! eigenvalue and occupancy variables !
!--------------------------------------------!
! number of empty states per atom and spin
real(8) nempty0
! number of empty states
integer nempty
! number of first-variational states
integer nstfv
! number of second-variational states
integer nstsv
! smearing type
integer stype
! smearing function description
character(256) sdescr
! smearing width
real(8) swidth
! autoswidth is .true. if the smearing width is to be determined automatically
logical autoswidth
! effective mass used in smearing width formula
real(8) mstar
! maximum allowed occupancy (1 or 2)
real(8) occmax
! convergence tolerance for occupancies
real(8) epsocc
! second-variational occupation numbers
real(8), allocatable :: occsv(:,:)
! Fermi energy for second-variational states
real(8) efermi
! scissor correction applied when computing response functions
real(8) scissor
! density of states at the Fermi energy
real(8) fermidos
! estimated indirect and direct band gaps
real(8) bandgap(2)
! k-points of indirect and direct gaps
integer ikgap(3)
! error tolerance for the first-variational eigenvalues
real(8) evaltol
! second-variational eigenvalues
real(8), allocatable :: evalsv(:,:)
! tevecsv is .true. if second-variational eigenvectors are calculated
logical tevecsv
! maximum number of k-point and states indices in user-defined list
integer, parameter :: maxkst=20
! number of k-point and states indices in user-defined list
integer nkstlist
! user-defined list of k-point and state indices
integer kstlist(2,maxkst)
!------------------------------!
! core state variables !
!------------------------------!
! occupancies for core states
real(8), allocatable :: occcr(:,:)
! eigenvalues for core states
real(8), allocatable :: evalcr(:,:)
! radial wavefunctions for core states
real(8), allocatable :: rwfcr(:,:,:,:)
! radial charge density for core states
real(8), allocatable :: rhocr(:,:,:)
! spincore is .true. if the core is to be treated as spin-polarised
logical spincore
! number of core spin-channels
integer nspncr
!--------------------------!
! energy variables !
!--------------------------!
! eigenvalue sum
real(8) evalsum
! electron kinetic energy
real(8) engykn
! core electron kinetic energy
real(8) engykncr
! nuclear-nuclear energy
real(8) engynn
! electron-nuclear energy
real(8) engyen
! Hartree energy
real(8) engyhar
! Coulomb energy (E_nn + E_en + E_H)
real(8) engycl
! electronic Coulomb potential energy
real(8) engyvcl
! Madelung term
real(8) engymad
! exchange-correlation potential energy
real(8) engyvxc
! exchange-correlation effective field energy
real(8) engybxc
! energy of external global magnetic field
real(8) engybext
! exchange energy
real(8) engyx
! correlation energy
real(8) engyc
! electronic entropy
real(8) entrpy
! entropic contribution to free energy
real(8) engyts
! total energy
real(8) engytot
!--------------------------------------------!
! force, stress and strain variables !
!--------------------------------------------!
! tforce is .true. if force should be calculated
logical tforce
! Hellmann-Feynman force on each atom
real(8), allocatable :: forcehf(:,:)
! incomplete basis set (IBS) force on each atom
real(8), allocatable :: forceibs(:,:)
! total force on each atom
real(8), allocatable :: forcetot(:,:)
! previous total force on each atom
real(8), allocatable :: forcetotp(:,:)
! maximum force magnitude over all atoms
real(8) forcemax
! tfav0 is .true. if the average force should be zero in order to prevent
! translation of the atomic basis
logical tfav0
! average force
real(8) forceav(3)
! atomic position optimisation type
! 0 : no optimisation
! 1 : unconstrained optimisation
integer atpopt
! maximum number of atomic position optimisation steps
integer maxatpstp
! default step size parameter for atomic position optimisation
real(8) tau0atp
! step size parameters for each atom
real(8), allocatable :: tauatp(:)
! number of strain tensors
integer nstrain
! current strain tensor
integer :: istrain=0
! strain tensors
real(8) strain(3,3,9)
! infinitesimal displacement parameter multiplied by the strain tensor for
! computing the stress tensor
real(8) deltast
! symmetry reduced stress tensor components
real(8) stress(9)
! previous stress tensor
real(8) stressp(9)
! stress tensor component magnitude maximum
real(8) stressmax
! lattice vector optimisation type
! 0 : no optimisation
! 1 : unconstrained optimisation
! 2 : iso-volumetric optimisation
integer latvopt
! maximum number of lattice vector optimisation steps
integer maxlatvstp
! default step size parameter for lattice vector optimisation
real(8) tau0latv
! step size for each stress tensor component acting on the lattice vectors
real(8) taulatv(9)
!-------------------------------!
! convergence variables !
!-------------------------------!
! maximum number of self-consistent loops
integer maxscl
! current self-consistent loop number
integer iscl
! Kohn-Sham potential convergence tolerance
real(8) epspot
! energy convergence tolerance
real(8) epsengy
! force convergence tolerance
real(8) epsforce
! stress tensor convergence tolerance
real(8) epsstress
!----------------------------------------------------------!
! density of states, optics and response variables !
!----------------------------------------------------------!
! number of energy intervals in the DOS/optics function plot
integer nwplot
! fine k-point grid size for integration of functions in the Brillouin zone
integer ngrkf
! smoothing level for DOS/optics function plot
integer nswplot
! energy interval for DOS/optics function plot
real(8) wplot(2)
! maximum angular momentum for the partial DOS plot
integer lmaxdos
! dosocc is .true. if the DOS is to be weighted by the occupancy
logical dosocc
! dosmsum is .true. if the partial DOS is to be summed over m
logical dosmsum
! dosssum is .true. if the partial DOS is to be summed over spin
logical dosssum
! number of optical matrix components required
integer noptcomp
! required optical matrix components
integer optcomp(3,27)
! intraband is .true. if the intraband term is to be added to the optical matrix
logical intraband
! lmirep is .true. if the (l,m) band characters should correspond to the
! irreducible representations of the site symmetries
logical lmirep
! spin-quantisation axis in Cartesian coordinates used when plotting the
! spin-resolved DOS (z-axis by default)
real(8) sqados(3)
! q-vector in lattice and Cartesian coordinates for calculating the matrix
! elements < i,k+q | exp(iq.r) | j,k >
real(8) vecql(3),vecqc(3)
! maximum initial-state energy allowed in ELNES transitions
real(8) emaxelnes
! structure factor energy window
real(8) wsfac(2)
!-------------------------------------!
! 1D/2D/3D plotting variables !
!-------------------------------------!
! number of vertices in 1D plot
integer nvp1d
! total number of points in 1D plot
integer npp1d
! vertices in lattice coordinates for 1D plot
real(8), allocatable :: vvlp1d(:,:)
! distance to vertices in 1D plot
real(8), allocatable :: dvp1d(:)
! plot vectors in lattice coordinates for 1D plot
real(8), allocatable :: vplp1d(:,:)
! distance to points in 1D plot
real(8), allocatable :: dpp1d(:)
! corner vectors of 2D plot in lattice coordinates
real(8) vclp2d(3,0:2)
! grid sizes of 2D plot
integer np2d(2)
! corner vectors of 3D plot in lattice coordinates
real(8) vclp3d(3,0:3)
! grid sizes of 3D plot
integer np3d(3)
!----------------------------------------!
! OEP and Hartree-Fock variables !
!----------------------------------------!
! maximum number of core states over all species
integer ncrmax
! maximum number of OEP iterations
integer maxitoep
! OEP step size and fraction of previous potential to be used as starting point
real(8) tauoep(2)
! magnitude of the OEP residual
real(8) resoep
! exchange potential and magnetic field
real(8), allocatable :: vxmt(:,:),vxir(:)
real(8), allocatable :: bxmt(:,:,:),bxir(:,:)
! hybrid is .true. if a hybrid functional is to be used
logical hybrid,hybrid0
! hybrid functional mixing coefficient
real(8) hybridc
!-------------------------------------------------------------!
! response function and perturbation theory variables !
!-------------------------------------------------------------!
! |G| cut-off for response functions
real(8) gmaxrf
! energy cut-off for response functions
real(8) emaxrf
! number of G-vectors for response functions
integer ngrf
! number of response function frequencies
integer nwrf
! complex response function frequencies
complex(8), allocatable :: wrf(:)
! maximum number of spherical Bessel functions on the coarse radial mesh over
! all species
integer njcmax
!-------------------------------------------------!
! Bethe-Salpeter equation (BSE) variables !
!-------------------------------------------------!
! number of valence and conduction states for transitions
integer nvbse,ncbse
! default number of valence and conduction states
integer nvbse0,ncbse0
! maximum number of extra valence and conduction states
integer, parameter :: maxxbse=20
! number of extra valence and conduction states
integer nvxbse,ncxbse
! extra valence and conduction states
integer istxbse(maxxbse),jstxbse(maxxbse)
! total number of transitions
integer nvcbse
! size of blocks in BSE Hamiltonian matrix
integer nbbse
! size of BSE matrix (= 2*nbbse)
integer nmbse
! index from BSE valence states to second-variational states
integer, allocatable :: istbse(:,:)
! index from BSE conduction states to second-variational states
integer, allocatable :: jstbse(:,:)
! index from BSE valence-conduction pair and k-point to location in BSE matrix
integer, allocatable :: ijkbse(:,:,:)
! BSE Hamiltonian
complex(8), allocatable :: hmlbse(:,:)
! BSE Hamiltonian eigenvalues
real(8), allocatable :: evalbse(:)
! if bsefull is .true. then the full BSE Hamiltonian is calculated, otherwise
! only the Hermitian block
logical bsefull
! if hxbse/hdbse is .true. then the exchange/direct term is included in the BSE
! Hamiltonian
logical hxbse,hdbse
!--------------------------!
! timing variables !
!--------------------------!
! initialisation
real(8) timeinit
! Hamiltonian and overlap matrix set up
real(8) timemat
! first-variational calculation
real(8) timefv
! second-variational calculation
real(8) timesv
! charge density calculation
real(8) timerho
! potential calculation
real(8) timepot
! force calculation
real(8) timefor
!-----------------------------!
! numerical constants !
!-----------------------------!
real(8), parameter :: pi=3.1415926535897932385d0
real(8), parameter :: twopi=6.2831853071795864769d0
real(8), parameter :: fourpi=12.566370614359172954d0
! spherical harmonic for l=m=0
real(8), parameter :: y00=0.28209479177387814347d0
! complex constants
complex(8), parameter :: zzero=(0.d0,0.d0)
complex(8), parameter :: zone=(1.d0,0.d0)
complex(8), parameter :: zi=(0.d0,1.d0)
! array of i^l and (-i)^l values
integer, private :: l
complex(8), parameter :: zil(0:maxlapw)=[((0.d0,1.d0)**l,l=0,maxlapw)]
complex(8), parameter :: zilc(0:maxlapw)=[((0.d0,-1.d0)**l,l=0,maxlapw)]
! Pauli spin matrices:
! sigma_x = ( 0 1 ) sigma_y = ( 0 -i ) sigma_z = ( 1 0 )
! ( 1 0 ) ( i 0 ) ( 0 -1 )
! Planck constant in SI units (exact, CODATA 2018)
real(8), parameter :: h_si=6.62607015d-34
! reduced Planck constant in SI units
real(8), parameter :: hbar_si=h_si/twopi
! speed of light in SI units (exact, CODATA 2018)
real(8), parameter :: sol_si=299792458d0
! speed of light in atomic units (=1/alpha) (CODATA 2018)
real(8), parameter :: sol=137.035999084d0
! scaled speed of light
real(8) solsc
! Hartree in SI units (CODATA 2018)
real(8), parameter :: ha_si=4.3597447222071d-18
! Hartree in eV (CODATA 2018)
real(8), parameter :: ha_ev=27.211386245988d0
! Hartree in inverse meters
real(8), parameter :: ha_im=ha_si/(h_si*sol_si)
! Boltzmann constant in SI units (exact, CODATA 2018)
real(8), parameter :: kb_si=1.380649d-23
! Boltzmann constant in Hartree/kelvin
real(8), parameter :: kboltz=kb_si/ha_si
! electron charge in SI units (exact, CODATA 2018)
real(8), parameter :: e_si=1.602176634d-19
! Bohr radius in SI units (CODATA 2018)
real(8), parameter :: br_si=0.529177210903d-10
! Bohr radius in Angstroms
real(8), parameter :: br_ang=br_si*1.d10
! atomic unit of magnetic flux density in SI
real(8), parameter :: b_si=hbar_si/(e_si*br_si**2)
! atomic unit of electric field in SI
real(8), parameter :: ef_si=ha_si/(e_si*br_si)
! atomic unit of time in SI
real(8), parameter :: t_si=hbar_si/ha_si
! electron g-factor (CODATA 2018)
real(8), parameter :: gfacte=2.00231930436256d0
! electron mass in SI (CODATA 2018)
real(8), parameter :: em_si=9.1093837015d-31
! atomic mass unit in SI (CODATA 2018)
real(8), parameter :: amu_si=1.66053906660d-27
! atomic mass unit in electron masses
real(8), parameter :: amu=amu_si/em_si
!---------------------------------!
! miscellaneous variables !
!---------------------------------!
! code version
integer, parameter :: version(3)=[7,2,42]
! maximum number of tasks
integer, parameter :: maxtasks=40
! number of tasks
integer ntasks
! task array
integer tasks(maxtasks)
! current task
integer task
! tlast is .true. if the calculation is on the last self-consistent loop
logical tlast
! tstop is .true. if the STOP file exists
logical tstop
! number of self-consistent loops after which STATE.OUT is written
integer nwrite
! filename extension for files generated by gndstate
character(256) :: filext='.OUT'
! scratch space path
character(256) scrpath
! number of note lines
integer notelns
! notes to include in INFO.OUT
character(256), allocatable :: notes(:)
end module
elk-7.2.42/src/PaxHeaders.21776/mpi_stub.f90 0000644 0000000 0000000 00000000131 14061636517 015065 x ustar 00 30 mtime=1623670095.967101515
29 atime=1623670093.54910376
30 ctime=1623670095.967101515
elk-7.2.42/src/mpi_stub.f90 0000644 0025044 0025044 00000003530 14061636517 017124 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for MPI.
module mpi
integer mpi_comm_world
integer mpi_in_place
integer mpi_sum
integer mpi_logical
integer mpi_integer
integer mpi_double_precision
integer mpi_double_complex
end module
subroutine mpi_init(ierror)
implicit none
integer, intent(out) :: ierror
ierror=0
end subroutine
subroutine mpi_finalize(ierror)
implicit none
integer, intent(out) :: ierror
ierror=0
end subroutine
subroutine mpi_comm_dup(comm,newcomm,ierror)
implicit none
integer, intent(in) :: comm
integer, intent(out) :: newcomm
integer, intent(out) :: ierror
newcomm=comm
ierror=0
end subroutine
subroutine mpi_comm_size(comm,size,ierror)
implicit none
integer, intent(in) :: comm
integer, intent(out) :: size
integer, intent(out) :: ierror
size=1
ierror=0
end subroutine
subroutine mpi_comm_rank(comm,rank,ierror)
implicit none
integer, intent(in) :: comm
integer, intent(out) :: rank
integer, intent(out) :: ierror
rank=0
ierror=0
end subroutine
subroutine mpi_barrier(comm,ierror)
implicit none
integer, intent(in) :: comm
integer, intent(out) :: ierror
ierror=0
end subroutine
subroutine mpi_bcast(buffer,count,datatype,root,comm,ierror)
implicit none
real(8), intent(in) :: buffer(*)
integer, intent(in) :: count
integer, intent(in) :: datatype
integer, intent(in) :: root
integer, intent(in) :: comm
integer, intent(out) :: ierror
ierror=0
end subroutine
subroutine mpi_allreduce(sendbuf,recvbuf,count,datatype,op,comm,ierror)
implicit none
real(8), intent(in) :: sendbuf(*)
real(8), intent(in) :: recvbuf(*)
integer, intent(in) :: count
integer, intent(in) :: datatype
integer, intent(in) :: op
integer, intent(in) :: comm
integer, intent(out) :: ierror
ierror=0
end subroutine
elk-7.2.42/src/PaxHeaders.21776/modmpi.f90 0000644 0000000 0000000 00000000132 14061636516 014530 x ustar 00 30 mtime=1623670094.836102565
30 atime=1623670093.551103758
30 ctime=1623670094.836102565
elk-7.2.42/src/modmpi.f90 0000644 0025044 0025044 00000000742 14061636516 016570 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modmpi
use mpi
! MPI communicator for main code
integer mpicom
! number of MPI processes
integer np_mpi
! local MPI process number
integer lp_mpi
! mp_mpi is .true. if the local MPI process is the master (0)
logical mp_mpi
! commonly used error variable
integer ierror
end module
elk-7.2.42/src/PaxHeaders.21776/modramdisk.f90 0000644 0000000 0000000 00000000132 14061636516 015375 x ustar 00 30 mtime=1623670094.838102563
30 atime=1623670093.553103756
30 ctime=1623670094.838102563
elk-7.2.42/src/modramdisk.f90 0000644 0025044 0025044 00000016363 14061636516 017443 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2021 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modramdisk
! ramdisk is .true. if the RAM disk should be used
logical ramdisk
! maximum allowed number of files in the RAM disk
integer, parameter, private :: maxfiles=20
! maximum number of records per file
integer, parameter, private :: maxrec=10000
! record data stored as 4-byte words
type, private :: rec_t
integer(4), allocatable :: dat(:)
end type
! RAM disk file consisting of the filename and an array of records
type, private :: file_t
character(256) fname
type(rec_t), allocatable :: rec(:)
end type
! arrays of files constituting the RAM disk
type(file_t), allocatable, private :: file(:)
! private subroutines
private findfile,openfile
contains
subroutine initrd
! this subroutine should not be called from a parallel region
implicit none
! local variables
integer i
if (allocated(file)) then
write(*,*)
write(*,'("Error(initrd): RAM disk already initialised")')
write(*,*)
stop
end if
allocate(file(maxfiles))
do i=1,maxfiles
file(i)%fname=''
end do
end subroutine
subroutine findfile(fname,fnum)
implicit none
! arguments
character(*), intent(in) :: fname
integer, intent(out) :: fnum
! local variables
integer i
if (.not.allocated(file)) then
write(*,*)
write(*,'("Error(findfile): RAM disk not initialised")')
write(*,*)
stop
end if
fnum=0
do i=1,maxfiles
if (file(i)%fname.eq.fname) then
fnum=i
return
end if
end do
end subroutine
subroutine openfile(fname,fnum)
implicit none
! arguments
character(*), intent(in) :: fname
integer, intent(out) :: fnum
! local variables
integer i
! check to see if the file already exists
call findfile(fname,fnum)
if (fnum.ne.0) return
! use the first available file number
do i=1,maxfiles
if (file(i)%fname.eq.'') then
! assign the filename
file(i)%fname=fname
! allocate the record array
allocate(file(i)%rec(maxrec))
fnum=i
return
end if
end do
write(*,*)
write(*,'("Error(openfile): too many RAM disk files open : ",I8)') maxfiles
write(*,*)
stop
end subroutine
subroutine delfrd(fname)
! this subroutine should not be called from a parallel region
implicit none
! arguments
character(*), intent(in) :: fname
! local variables
integer fnum,i
! determine the file number
call findfile(fname,fnum)
! return if the file does not exist
if (fnum.eq.0) return
! erase filename
file(fnum)%fname=''
! deallocate associated arrays
do i=1,maxrec
if (allocated(file(fnum)%rec(i)%dat)) then
deallocate(file(fnum)%rec(i)%dat)
end if
end do
deallocate(file(fnum)%rec)
end subroutine
subroutine putrd(fname,irec,n1,n2,n3,v1,v2,nrv,rva,nzv,zva)
! this subroutine should be called from a critical section
implicit none
! arguments
character(*), intent(in) :: fname
integer, intent(in) :: irec
integer, optional, intent(in) :: n1,n2,n3
real(8), optional, intent(in) :: v1(3),v2(3)
integer, optional, intent(in) :: nrv
real(8), optional, intent(in) :: rva(*)
integer, optional, intent(in) :: nzv
complex(8), optional, intent(in) :: zva(*)
! local variables
integer fnum,n,i
if (irec.gt.maxrec) return
! find the record length in 4-byte words
n=0
if (present(n1)) n=n+1
if (present(n2)) n=n+1
if (present(n3)) n=n+1
if (present(v1)) n=n+6
if (present(v2)) n=n+6
if (present(rva)) then
if (present(nrv)) then
n=n+2*nrv
else
write(*,*)
write(*,'("Error(putrd): missing argument nrv")')
write(*,*)
stop
end if
end if
if (present(zva)) then
if (present(nzv)) then
n=n+4*nzv
else
write(*,*)
write(*,'("Error(putrd): missing argument nzv")')
write(*,*)
stop
end if
end if
! open the file
call openfile(fname,fnum)
! allocate the record data array if required
if (allocated(file(fnum)%rec(irec)%dat)) then
if (size(file(fnum)%rec(irec)%dat).lt.n) then
deallocate(file(fnum)%rec(irec)%dat)
end if
end if
if (.not.allocated(file(fnum)%rec(irec)%dat)) then
allocate(file(fnum)%rec(irec)%dat(n))
end if
i=1
if (present(n1)) then
file(fnum)%rec(irec)%dat(i)=n1
i=i+1
end if
if (present(n2)) then
file(fnum)%rec(irec)%dat(i)=n2
i=i+1
end if
if (present(n3)) then
file(fnum)%rec(irec)%dat(i)=n3
i=i+1
end if
if (present(v1)) then
call dcopy(3,v1,1,file(fnum)%rec(irec)%dat(i),1)
i=i+6
end if
if (present(v2)) then
call dcopy(3,v2,1,file(fnum)%rec(irec)%dat(i),1)
i=i+6
end if
if (present(rva)) then
call dcopy(nrv,rva,1,file(fnum)%rec(irec)%dat(i),1)
i=i+2*nrv
end if
if (present(zva)) then
call zcopy(nzv,zva,1,file(fnum)%rec(irec)%dat(i),1)
end if
end subroutine
subroutine getrd(fname,irec,tgs,n1,n2,n3,v1,v2,nrv,rva,nzv,zva)
implicit none
! arguments
character(*), intent(in) :: fname
integer, intent(in) :: irec
logical, intent(out) :: tgs
integer, optional, intent(out) :: n1,n2,n3
real(8), optional, intent(out) :: v1(3),v2(3)
integer, optional, intent(in) :: nrv
real(8), optional, intent(out) :: rva(*)
integer, optional, intent(in) :: nzv
complex(8), optional, intent(out) :: zva(*)
! local variables
integer fnum,n,i
if (present(rva)) then
if (.not.present(nrv)) then
write(*,*)
write(*,'("Error(getrd): missing argument nrv")')
write(*,*)
stop
end if
end if
if (present(zva)) then
if (.not.present(nzv)) then
write(*,*)
write(*,'("Error(getrd): missing argument nzv")')
write(*,*)
stop
end if
end if
tgs=.false.
if (irec.gt.maxrec) return
! determine the file number
call findfile(fname,fnum)
! return unsuccessfully if file is not found or record is unavailable
if (fnum.eq.0) return
if (.not.allocated(file(fnum)%rec(irec)%dat)) return
n=size(file(fnum)%rec(irec)%dat)
i=1
if (present(n1)) then
if (n.lt.1) return
n1=file(fnum)%rec(irec)%dat(i)
i=i+1
n=n-1
end if
if (present(n2)) then
if (n.lt.1) return
n2=file(fnum)%rec(irec)%dat(i)
i=i+1
n=n-1
end if
if (present(n3)) then
if (n.lt.1) return
n3=file(fnum)%rec(irec)%dat(i)
i=i+1
n=n-1
end if
if (present(v1)) then
if (n.lt.6) return
call dcopy(3,file(fnum)%rec(irec)%dat(i),1,v1,1)
i=i+6
n=n-6
end if
if (present(v2)) then
if (n.lt.6) return
call dcopy(3,file(fnum)%rec(irec)%dat(i),1,v2,1)
i=i+6
n=n-6
end if
if (present(rva)) then
if (n.lt.2*nrv) return
call dcopy(nrv,file(fnum)%rec(irec)%dat(i),1,rva,1)
i=i+2*nrv
n=n-2*nrv
end if
if (present(zva)) then
if (n.lt.4*nzv) return
call zcopy(nzv,file(fnum)%rec(irec)%dat(i),1,zva,1)
end if
! flag the get operation as successful
tgs=.true.
end subroutine
subroutine rdstatus
! this subroutine should not be called from a parallel region
implicit none
! local variables
integer nf,nr,i,j
integer(8) m,n
write(*,*)
write(*,'("Info(rdstatus):")')
if (.not.allocated(file)) then
write(*,'(" RAM disk not initialised")')
return
end if
nf=0
n=0
do i=1,maxfiles
if (file(i)%fname.ne.'') then
write(*,*)
write(*,'(" Filename : ",A)') trim(file(i)%fname)
nf=nf+1
nr=0
m=0
do j=1,maxrec
if (allocated(file(i)%rec(j)%dat)) then
nr=nr+1
m=m+size(file(i)%rec(j)%dat)
end if
end do
n=n+m
write(*,'(" number of records : ",I8)') nr
write(*,'(" total number of bytes : ",I14)') 4*m
end if
end do
write(*,*)
write(*,'(" Number of files on RAM disk : ",I4)') nf
write(*,'(" Total number of bytes used by RAM disk : ",I14)') 4*n
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/libxcifc_stub.f90 0000644 0000000 0000000 00000000132 14061636517 016064 x ustar 00 30 mtime=1623670095.987101497
30 atime=1623670093.555103754
30 ctime=1623670095.987101497
elk-7.2.42/src/libxcifc_stub.f90 0000644 0025044 0025044 00000004163 14061636517 020125 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2009 T. McQueen and J. K. Dewhurst.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for libxc. See Elk manual for libxc installation instructions.
module libxcifc
integer libxcv(3)
integer, parameter :: XC_MGGA_X_TB09=208
contains
subroutine xcifc_libxc(xctype,n,c_tb09,tempa,rho,rhoup,rhodn,g2rho,g2up,g2dn, &
grho2,gup2,gdn2,gupdn,tau,tauup,taudn,ex,ec,vx,vc,vxup,vxdn,vcup,vcdn,dxdgr2, &
dxdgu2,dxdgd2,dxdgud,dcdgr2,dcdgu2,dcdgd2,dcdgud,dxdg2r,dxdg2u,dxdg2d,dcdg2r, &
dcdg2u,dcdg2d,wx,wxup,wxdn,wc,wcup,wcdn)
implicit none
! mandatory arguments
integer, intent(in) :: xctype(3),n
! optional arguments
real(8), optional :: c_tb09,tempa
real(8), optional :: rho(n),rhoup(n),rhodn(n)
real(8), optional :: g2rho(n),g2up(n),g2dn(n)
real(8), optional :: grho2(n),gup2(n),gdn2(n),gupdn(n)
real(8), optional :: tau(n),tauup(n),taudn(n)
real(8), optional :: ex(n),ec(n),vx(n),vc(n)
real(8), optional :: vxup(n),vxdn(n),vcup(n),vcdn(n)
real(8), optional :: dxdgr2(n),dxdgu2(n),dxdgd2(n),dxdgud(n)
real(8), optional :: dcdgr2(n),dcdgu2(n),dcdgd2(n),dcdgud(n)
real(8), optional :: dxdg2r(n),dxdg2u(n),dxdg2d(n)
real(8), optional :: dcdg2r(n),dcdg2u(n),dcdg2d(n)
real(8), optional :: wx(n),wxup(n),wxdn(n)
real(8), optional :: wc(n),wcup(n),wcdn(n)
write(*,*)
write(*,'("Error(libxcifc): libxc not or improperly installed")')
write(*,*)
stop
end subroutine
subroutine fxcifc_libxc(fxctype,n,rho,rhoup,rhodn,fxc,fxcuu,fxcud,fxcdd)
implicit none
! mandatory arguments
integer, intent(in) :: fxctype(3),n
! optional arguments
real(8), optional :: rho(n),rhoup(n),rhodn(n)
real(8), optional :: fxc(n),fxcuu(n),fxcud(n),fxcdd(n)
write(*,*)
write(*,'("Error(libxcifc): libxc not or improperly installed")')
write(*,*)
stop
end subroutine
subroutine xcdata_libxc(xctype,xcdescr,xcspin,xcgrad,hybrid,hybridc)
implicit none
! arguments
integer xctype(3)
character(512) xcdescr
integer xcspin
integer xcgrad
logical hybrid
real(8) hybridc
write(*,*)
write(*,'("Error(libxcifc): libxc not or improperly installed")')
write(*,*)
stop
end subroutine
!EOC
end module
elk-7.2.42/src/PaxHeaders.21776/modxcifc.f90 0000644 0000000 0000000 00000000132 14061636516 015037 x ustar 00 30 mtime=1623670094.841102561
30 atime=1623670093.556103753
30 ctime=1623670094.841102561
elk-7.2.42/src/modxcifc.f90 0000644 0025044 0025044 00000040731 14061636516 017101 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modxcifc
use libxcifc
contains
!BOP
! !ROUTINE: xcifc
! !INTERFACE:
subroutine xcifc(xctype,n,c_tb09,tempa,rho,rhoup,rhodn,grho,gup,gdn,g2rho, &
g2up,g2dn,g3rho,g3up,g3dn,grho2,gup2,gdn2,gupdn,tau,tauup,taudn,ex,ec,vx,vc, &
vxup,vxdn,vcup,vcdn,dxdgr2,dxdgu2,dxdgd2,dxdgud,dcdgr2,dcdgu2,dcdgd2,dcdgud, &
dxdg2r,dxdg2u,dxdg2d,dcdg2r,dcdg2u,dcdg2d,wx,wxup,wxdn,wc,wcup,wcdn)
! !INPUT/OUTPUT PARAMETERS:
! xctype : type of exchange-correlation functional (in,integer(3))
! n : number of density points (in,integer)
! c_tb09 : Tran-Blaha '09 constant c (in,real,optional)
! tempa : temperature in atomic units (in,real,optional)
! rho : spin-unpolarised charge density (in,real(n),optional)
! rhoup : spin-up charge density (in,real(n),optional)
! rhodn : spin-down charge density (in,real(n),optional)
! grho : |grad rho| (in,real(n),optional)
! gup : |grad rhoup| (in,real(n),optional)
! gdn : |grad rhodn| (in,real(n),optional)
! g2rho : grad^2 rho (in,real(n),optional)
! g2up : grad^2 rhoup (in,real(n),optional)
! g2dn : grad^2 rhodn (in,real(n),optional)
! g3rho : (grad rho).(grad |grad rho|) (in,real(n),optional)
! g3up : (grad rhoup).(grad |grad rhoup|) (in,real(n),optional)
! g3dn : (grad rhodn).(grad |grad rhodn|) (in,real(n),optional)
! grho2 : |grad rho|^2 (in,real(n),optional)
! gup2 : |grad rhoup|^2 (in,real(n),optional)
! gdn2 : |grad rhodn|^2 (in,real(n),optional)
! gupdn : (grad rhoup).(grad rhodn) (in,real(n),optional)
! tau : kinetic energy density (in,real(n),optional)
! tauup : spin-up kinetic energy density (in,real(n),optional)
! taudn : spin-down kinetic energy density (in,real(n),optional)
! ex : exchange energy density (out,real(n),optional)
! ec : correlation energy density (out,real(n),optional)
! vx : spin-unpolarised exchange potential (out,real(n),optional)
! vc : spin-unpolarised correlation potential (out,real(n),optional)
! vxup : spin-up exchange potential (out,real(n),optional)
! vxdn : spin-down exchange potential (out,real(n),optional)
! vcup : spin-up correlation potential (out,real(n),optional)
! vcdn : spin-down correlation potential (out,real(n),optional)
! dxdgr2 : de_x/d(|grad rho|^2) (out,real(n),optional)
! dxdgu2 : de_x/d(|grad rhoup|^2) (out,real(n),optional)
! dxdgd2 : de_x/d(|grad rhodn|^2) (out,real(n),optional)
! dxdgud : de_x/d((grad rhoup).(grad rhodn)) (out,real(n),optional)
! dcdgr2 : de_c/d(|grad rho|^2) (out,real(n),optional)
! dcdgu2 : de_c/d(|grad rhoup|^2) (out,real(n),optional)
! dcdgd2 : de_c/d(|grad rhodn|^2) (out,real(n),optional)
! dcdgud : de_c/d((grad rhoup).(grad rhodn)) (out,real(n),optional)
! dxdg2r : de_x/d(grad^2 rho) (out,real(n),optional)
! dxdg2u : de_x/d(grad^2 rhoup) (out,real(n),optional)
! dxdg2d : de_x/d(grad^2 rhodn) (out,real(n),optional)
! dcdg2r : de_c/d(grad^2 rho) (out,real(n),optional)
! dcdg2u : de_c/d(grad^2 rhoup) (out,real(n),optional)
! dcdg2d : de_c/d(grad^2 rhodn) (out,real(n),optional)
! wx : de_x/dtau (out,real(n),optional)
! wxup : de_x/dtauup (out,real(n),optional)
! wxdn : de_x/dtaudn (out,real(n),optional)
! wc : de_c/dtau (out,real(n),optional)
! wcup : de_c/dtauup (out,real(n),optional)
! wcdn : de_c/dtaudn (out,real(n),optional)
! !DESCRIPTION:
! Interface to the exchange-correlation routines. In the most general case
! (meta-GGA), the exchange-correlation energy is given by
! $$ E_{xc}[\rho^{\uparrow},\rho^{\downarrow}]=\int d^3r\,
! \rho({\bf r})\,\varepsilon_{xc}(\rho^{\uparrow},\rho^{\downarrow},
! |\nabla\rho|,|\nabla\rho^{\uparrow}|,|\nabla\rho^{\downarrow}|,
! \nabla^2\rho^{\uparrow},\nabla^2\rho^{\downarrow},\tau), $$
! where $\rho({\bf r})=\rho^{\uparrow}({\bf r})+\rho^{\downarrow}({\bf r})$ is
! the density;
! $$ \tau({\bf r})\equiv\sum_{i\;{\rm occ}}\nabla\psi({\bf r})\cdot
! \nabla\psi({\bf r}) $$
! is twice the spin-contracted kinetic energy density; and $\varepsilon_{xc}$
! is the exchange-correlation energy per electron.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! mandatory arguments
integer, intent(in) :: xctype(3)
integer, intent(in) :: n
! optional arguments
real(8), optional, intent(in) :: c_tb09,tempa
real(8), optional, intent(in) :: rho(n),rhoup(n),rhodn(n)
real(8), optional, intent(in) :: grho(n),gup(n),gdn(n)
real(8), optional, intent(in) :: g2rho(n),g2up(n),g2dn(n)
real(8), optional, intent(in) :: g3rho(n),g3up(n),g3dn(n)
real(8), optional, intent(in) :: grho2(n),gup2(n),gdn2(n),gupdn(n)
real(8), optional, intent(in) :: tau(n),tauup(n),taudn(n)
real(8), optional, intent(out) :: ex(n),ec(n),vx(n),vc(n)
real(8), optional, intent(out) :: vxup(n),vxdn(n),vcup(n),vcdn(n)
real(8), optional, intent(out) :: dxdgr2(n),dxdgu2(n),dxdgd2(n),dxdgud(n)
real(8), optional, intent(out) :: dxdg2r(n),dxdg2u(n),dxdg2d(n)
real(8), optional, intent(out) :: wx(n),wxup(n),wxdn(n)
real(8), optional, intent(out) :: dcdgr2(n),dcdgu2(n),dcdgd2(n),dcdgud(n)
real(8), optional, intent(out) :: dcdg2r(n),dcdg2u(n),dcdg2d(n)
real(8), optional, intent(out) :: wc(n),wcup(n),wcdn(n)
! local variables
real(8) kappa,mu,beta
! allocatable arrays
real(8), allocatable :: ra(:,:)
if (n.le.0) then
write(*,*)
write(*,'("Error(xcifc): n <= 0 : ",I8)') n
write(*,*)
stop
end if
select case(abs(xctype(1)))
case(1)
! No density-derived exchange-correlation energy or potential
if (present(ex)) ex(:)=0.d0
if (present(ec)) ec(:)=0.d0
if (present(vx)) vx(:)=0.d0
if (present(vc)) vc(:)=0.d0
if (present(vxup)) vxup(:)=0.d0
if (present(vxdn)) vxdn(:)=0.d0
if (present(vcup)) vcup(:)=0.d0
if (present(vcdn)) vcdn(:)=0.d0
case(2)
! Perdew-Zunger parameterisation of Ceperley-Alder electron gas
! J. Perdew and A. Zunger, Phys. Rev. B 23, 5048 (1981)
! D. M. Ceperly and B. J. Alder, Phys. Rev. Lett. 45, 566 (1980)
if (present(rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
call xc_pzca(n,rho,ex,ec,vx,vc)
else
goto 10
end if
case(3)
! Perdew-Wang parameterisation of the spin-polarised Ceperley-Alder electron gas
! J. Perdew and Y. Wang, Phys. Rev. B 45, 13244 (1992)
! D. M. Ceperly and B. J. Alder, Phys. Rev. Lett. 45, 566 (1980)
if (present(rhoup).and.present(rhodn).and.present(ex).and.present(ec) &
.and.present(vxup).and.present(vxdn).and.present(vcup) &
.and.present(vcdn)) then
! spin-polarised density
call xc_pwca(n,rhoup,rhodn,ex,ec,vxup,vxdn,vcup,vcdn)
else if (present(rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
! divide spin-unpolarised density into up and down
allocate(ra(n,1))
ra(:,1)=0.5d0*rho(:)
call xc_pwca(n,ra,ra,ex,ec,vx,vx,vc,vc)
deallocate(ra)
else
goto 10
end if
case(4)
! X-alpha approximation
! J. C. Slater, Phys. Rev. 81, 385 (1951)
if (present(rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
call xc_xalpha(n,rho,ex,vx)
! set correlation energy and potential to zero
ec(:)=0.d0
vc(:)=0.d0
else
goto 10
end if
case(5)
! U. von Barth and L. Hedin parameterisation of LSDA
! J. Phys. C, 5, 1629 (1972)
if (present(rhoup).and.present(rhodn).and.present(ex).and.present(ec) &
.and.present(vxup).and.present(vxdn).and.present(vcup) &
.and.present(vcdn)) then
! spin-polarised density
call xc_vbh(n,rhoup,rhodn,ex,ec,vxup,vxdn,vcup,vcdn)
else if (present(rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
! divide spin-unpolarised density into up and down
allocate(ra(n,1))
ra(:,1)=0.5d0*rho(:)
call xc_vbh(n,ra,ra,ex,ec,vx,vx,vc,vc)
deallocate(ra)
else
goto 10
end if
case(20,21,22)
! original PBE kappa
kappa=0.804d0
if (xctype(1).eq.21) then
! Zhang-Yang kappa
kappa=1.245d0
end if
! original PBE mu and beta
mu=0.2195149727645171d0
beta=0.06672455060314922d0
if (xctype(1).eq.22) then
! PBEsol parameters
mu=10.d0/81.d0
beta=0.046d0
end if
! Perdew-Burke-Ernzerhof generalised gradient approximation
! Phys. Rev. Lett. 77, 3865 (1996); 78, 1396(E) (1997)
! Revised PBE, Zhang-Yang, Phys. Rev. Lett. 80, 890 (1998)
if (present(rhoup).and.present(rhodn).and.present(grho).and.present(gup) &
.and.present(gdn).and.present(g2up).and.present(g2dn).and.present(g3rho) &
.and.present(g3up).and.present(g3dn).and.present(ex).and.present(ec) &
.and.present(vxup).and.present(vxdn).and.present(vcup) &
.and.present(vcdn)) then
call xc_pbe(n,kappa,mu,beta,rhoup,rhodn,grho,gup,gdn,g2up,g2dn,g3rho,g3up, &
g3dn,ex,ec,vxup,vxdn,vcup,vcdn)
else if (present(rho).and.present(grho).and.present(g2rho) &
.and.present(g3rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
allocate(ra(n,6))
ra(:,1)=0.5d0*rho(:)
ra(:,2)=0.5d0*grho(:)
ra(:,3)=0.5d0*g2rho(:)
ra(:,4)=0.25d0*g3rho(:)
call xc_pbe(n,kappa,mu,beta,ra,ra,grho,ra(:,2),ra(:,2),ra(:,3),ra(:,3), &
g3rho,ra(:,4),ra(:,4),ex,ec,vx,ra(:,5),vc,ra(:,6))
deallocate(ra)
else
goto 10
end if
case(26)
! Wu-Cohen exchange with PBE correlation generalised gradient functional
! Zhigang Wu and R. E. Cohen, Phys. Rev. B 73, 235116 (2006)
if (present(rho).and.present(grho).and.present(g2rho).and.present(g3rho) &
.and.present(ex).and.present(ec).and.present(vx).and.present(vc)) then
call xc_wc06(n,rho,grho,g2rho,g3rho,ex,ec,vx,vc)
else
goto 10
end if
case(30)
! Armiento-Mattsson generalised gradient functional
! R. Armiento and A. E. Mattsson, Phys. Rev. B 72, 085108 (2005)
if (present(rho).and.present(grho).and.present(g2rho).and.present(g3rho) &
.and.present(ex).and.present(ec).and.present(vx).and.present(vc)) then
call xc_am05(n,rho,grho,g2rho,g3rho,ex,ec,vx,vc)
else
goto 10
end if
case(100)
! libxc library functionals
if (present(rhoup).and.present(rhodn).and.present(g2up).and.present(g2dn) &
.and.present(gup2).and.present(gdn2).and.present(gupdn).and.present(tauup) &
.and.present(taudn).and.present(ex).and.present(ec).and.present(vxup) &
.and.present(vxdn).and.present(vcup).and.present(vcdn).and.present(dxdgu2) &
.and.present(dxdgd2).and.present(dxdgud).and.present(dcdgu2) &
.and.present(dcdgd2).and.present(dcdgud).and.present(dxdg2u) &
.and.present(dxdg2d).and.present(dcdg2u).and.present(dcdg2d) &
.and.present(wxup).and.present(wxdn).and.present(wcup) &
.and.present(wcdn)) then
! spin-polarised energy meta-GGA
call xcifc_libxc(xctype,n,rhoup=rhoup,rhodn=rhodn,g2up=g2up,g2dn=g2dn, &
gup2=gup2,gdn2=gdn2,gupdn=gupdn,tauup=tauup,taudn=taudn,ex=ex,ec=ec, &
vxup=vxup,vxdn=vxdn,vcup=vcup,vcdn=vcdn,dxdgu2=dxdgu2,dxdgd2=dxdgd2, &
dxdgud=dxdgud,dcdgu2=dcdgu2,dcdgd2=dcdgd2,dcdgud=dcdgud,dxdg2u=dxdg2u, &
dxdg2d=dxdg2d,dcdg2u=dcdg2u,dcdg2d=dcdg2d,wxup=wxup,wxdn=wxdn,wcup=wcup, &
wcdn=wcdn)
else if (present(rhoup).and.present(rhodn).and.present(g2up) &
.and.present(g2dn).and.present(gup2).and.present(gdn2).and.present(gupdn) &
.and.present(tauup).and.present(taudn).and.present(vxup).and.present(vxdn) &
.and.present(vcup).and.present(vcdn)) then
! spin-polarised potential-only meta-GGA
call xcifc_libxc(xctype,n,c_tb09=c_tb09,rhoup=rhoup,rhodn=rhodn,g2up=g2up, &
g2dn=g2dn,gup2=gup2,gdn2=gdn2,gupdn=gupdn,tauup=tauup,taudn=taudn, &
vxup=vxup,vxdn=vxdn,vcup=vcup,vcdn=vcdn)
else if (present(rhoup).and.present(rhodn).and.present(gup2) &
.and.present(gdn2).and.present(gupdn).and.present(ex).and.present(ec) &
.and.present(vxup).and.present(vxdn).and.present(vcup).and.present(vcdn) &
.and.present(dxdgu2).and.present(dxdgd2).and.present(dxdgud) &
.and.present(dcdgu2).and.present(dcdgd2).and.present(dcdgud)) then
! spin-polarised GGA
call xcifc_libxc(xctype,n,rhoup=rhoup,rhodn=rhodn,gup2=gup2,gdn2=gdn2, &
gupdn=gupdn,ex=ex,ec=ec,vxup=vxup,vxdn=vxdn,vcup=vcup,vcdn=vcdn, &
dxdgu2=dxdgu2,dxdgd2=dxdgd2,dxdgud=dxdgud,dcdgu2=dcdgu2,dcdgd2=dcdgd2, &
dcdgud=dcdgud)
else if (present(rhoup).and.present(rhodn).and.present(ex).and.present(ec) &
.and.present(vxup).and.present(vxdn).and.present(vcup) &
.and.present(vcdn)) then
! LSDA
call xcifc_libxc(xctype,n,tempa=tempa,rhoup=rhoup,rhodn=rhodn,ex=ex,ec=ec, &
vxup=vxup,vxdn=vxdn,vcup=vcup,vcdn=vcdn)
else if (present(rho).and.present(g2rho).and.present(grho2).and.present(tau) &
.and.present(ex).and.present(ec).and.present(vx).and.present(vc) &
.and.present(dxdgr2).and.present(dcdgr2).and.present(dxdg2r) &
.and.present(dcdg2r).and.present(wx).and.present(wc)) then
! spin-unpolarised energy meta-GGA
call xcifc_libxc(xctype,n,rho=rho,g2rho=g2rho,grho2=grho2,tau=tau,ex=ex, &
ec=ec,vx=vx,vc=vc,dxdgr2=dxdgr2,dcdgr2=dcdgr2,dxdg2r=dxdg2r, &
dcdg2r=dcdg2r,wx=wx,wc=wc)
else if (present(rho).and.present(g2rho).and.present(grho2).and.present(tau) &
.and.present(vx).and.present(vc)) then
! spin-unpolarised potential-only meta-GGA
call xcifc_libxc(xctype,n,c_tb09=c_tb09,rho=rho,g2rho=g2rho,grho2=grho2, &
tau=tau,vx=vx,vc=vc)
else if (present(rho).and.present(grho2).and.present(ex).and.present(ec) &
.and.present(vx).and.present(vc).and.present(dxdgr2) &
.and.present(dcdgr2)) then
! spin-unpolarised GGA
call xcifc_libxc(xctype,n,rho=rho,grho2=grho2,ex=ex,ec=ec,vx=vx,vc=vc, &
dxdgr2=dxdgr2,dcdgr2=dcdgr2)
else if (present(rho).and.present(ex).and.present(ec).and.present(vx) &
.and.present(vc)) then
! LDA
call xcifc_libxc(xctype,n,tempa=tempa,rho=rho,ex=ex,ec=ec,vx=vx,vc=vc)
else
goto 10
end if
case default
write(*,*)
write(*,'("Error(xcifc): xctype not defined : ",I8)') xctype(1)
write(*,*)
stop
end select
! set exchange potential to zero for EXX
if (xctype(1).le.-2) then
if (present(vx)) vx(:)=0.d0
if (present(vxup)) vxup(:)=0.d0
if (present(vxdn)) vxdn(:)=0.d0
end if
return
10 continue
write(*,*)
write(*,'("Error(xcifc): missing arguments for exchange-correlation type ",&
&3I6)') xctype(:)
write(*,*)
stop
end subroutine
!EOC
!BOP
! !ROUTINE: getxcdata
! !INTERFACE:
subroutine getxcdata(xctype,xcdescr,xcspin,xcgrad,hybrid,hybridc)
! !INPUT/OUTPUT PARAMETERS:
! xctype : type of exchange-correlation functional (in,integer(3))
! xcdescr : description of functional (out,character(512))
! xcspin : spin treatment (out,integer)
! xcgrad : gradient treatment (out,integer)
! hybrid : .true. if functional a hybrid (out,logical)
! hybridc : hybrid exact exchange mixing coefficient (out,real(8))
! !DESCRIPTION:
! Returns data on the exchange-correlation functional labeled by {\tt xctype}.
! The character array {\tt xcdescr} contains a short description of the
! functional including journal references. The variable {\tt xcspin} is set to
! 1 or 0 for spin-polarised or -unpolarised functionals, respectively. For
! functionals which require the gradients of the density {\tt xcgrad} is set
! to 1, otherwise it is set to 0.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: xctype(3)
character(512), intent(out) :: xcdescr
integer, intent(out) :: xcspin,xcgrad
logical, intent(out) :: hybrid
real(8), intent(out) :: hybridc
select case(abs(xctype(1)))
case(1)
xcdescr='No density-derived exchange-correlation energy or potential'
! spin-polarisation or gradient status not required
xcspin=-1
xcgrad=-1
case(2)
xcdescr='Perdew-Zunger/Ceperley-Alder, Phys. Rev. B 23, 5048 (1981)'
xcspin=0
xcgrad=0
case(3)
xcdescr='Perdew-Wang/Ceperley-Alder, Phys. Rev. B 45, 13244 (1992)'
xcspin=1
xcgrad=0
case(4)
xcdescr='X-alpha approximation, J. C. Slater, Phys. Rev. 81, 385 (1951)'
xcspin=0
xcgrad=0
case(5)
xcdescr='von Barth-Hedin, J. Phys. C 5, 1629 (1972)'
xcspin=1
xcgrad=0
case(20)
xcdescr='Perdew-Burke-Ernzerhof, Phys. Rev. Lett. 77, 3865 (1996)'
xcspin=1
xcgrad=1
case(21)
xcdescr='Revised PBE, Zhang-Yang, Phys. Rev. Lett. 80, 890 (1998)'
xcspin=1
xcgrad=1
case(22)
xcdescr='PBEsol, Phys. Rev. Lett. 100, 136406 (2008)'
xcspin=1
xcgrad=1
case(26)
xcdescr='Wu-Cohen exchange + PBE correlation, Phys. Rev. B 73, 235116 (2006)'
xcspin=0
xcgrad=1
case(30)
xcdescr='Armiento-Mattsson functional, Phys. Rev. B 72, 85108 (2005)'
xcspin=0
xcgrad=1
case(100)
! libxc library functionals
call xcdata_libxc(xctype,xcdescr,xcspin,xcgrad,hybrid,hybridc)
case default
write(*,*)
write(*,'("Error(getxcdata): xctype not defined : ",I8)') xctype(1)
write(*,*)
stop
end select
end subroutine
!EOC
end module
elk-7.2.42/src/PaxHeaders.21776/modfxcifc.f90 0000644 0000000 0000000 00000000132 14061636516 015205 x ustar 00 30 mtime=1623670094.843102559
30 atime=1623670093.558103751
30 ctime=1623670094.843102559
elk-7.2.42/src/modfxcifc.f90 0000644 0025044 0025044 00000004127 14061636516 017246 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2011 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modfxcifc
use libxcifc
contains
subroutine fxcifc(fxctype,n,rho,rhoup,rhodn,fxc,fxcuu,fxcud,fxcdd)
implicit none
! mandatory arguments
integer, intent(in) :: fxctype(3),n
! optional arguments
real(8), optional, intent(in) :: rho(n),rhoup(n),rhodn(n)
real(8), optional, intent(out) :: fxc(n),fxcuu(n),fxcud(n),fxcdd(n)
! allocatable arrays
real(8), allocatable :: ra(:,:)
if (n.le.0) then
write(*,*)
write(*,'("Error(fxcifc): n <= 0 : ",I8)') n
write(*,*)
stop
end if
select case(abs(fxctype(1)))
case(0,1)
! f_xc = 0
if (present(fxcuu).and.present(fxcud).and.present(fxcdd)) then
fxcuu(:)=0.d0
fxcud(:)=0.d0
fxcdd(:)=0.d0
else if (present(fxc)) then
fxc(:)=0.d0
else
goto 10
end if
case(3)
! Perdew-Wang-Ceperley-Alder
if (present(rhoup).and.present(rhodn).and.present(fxcuu).and.present(fxcud) &
.and.present(fxcdd)) then
! spin-polarised density
call fxc_pwca(n,rhoup,rhodn,fxcuu,fxcud,fxcdd)
else if (present(rho).and.present(fxc)) then
! divide spin-unpolarised density into up and down
allocate(ra(n,4))
ra(:,1)=0.5d0*rho(:)
call fxc_pwca(n,ra(:,1),ra(:,1),ra(:,2),ra(:,3),ra(:,4))
fxc(:)=0.5d0*(ra(:,2)+ra(:,3))
deallocate(ra)
else
goto 10
end if
case(100)
! libxc library functionals
if (present(rhoup).and.present(rhodn).and.present(fxcuu).and.present(fxcud) &
.and.present(fxcdd)) then
! LSDA
call fxcifc_libxc(fxctype,n,rhoup=rhoup,rhodn=rhodn,fxcuu=fxcuu, &
fxcud=fxcud,fxcdd=fxcdd)
else if (present(rho).and.present(fxc)) then
! LDA
call fxcifc_libxc(fxctype,n,rho=rho,fxc=fxc)
else
goto 10
end if
case default
write(*,*)
write(*,'("Error(fxcifc): response function unavailable for fxctype ",3I8)') &
fxctype
write(*,*)
stop
end select
return
10 continue
write(*,*)
write(*,'("Error(fxcifc): missing arguments for exchange-correlation type ",&
&3I6)') fxctype(:)
write(*,*)
stop
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/moddftu.f90 0000644 0000000 0000000 00000000131 14061636516 014704 x ustar 00 30 mtime=1623670094.844102558
29 atime=1623670093.56010375
30 ctime=1623670094.844102558
elk-7.2.42/src/moddftu.f90 0000644 0025044 0025044 00000006277 14061636516 016756 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2008 F. Bultmark, F. Cricchio and L. Nordstrom.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module moddftu
use modmain
!-----------------------------------------------------------!
! muffin-tin density and potential matrix variables !
!-----------------------------------------------------------!
! maximum angular momentum for muffin-tin density matrix
integer, parameter :: lmaxdm=3
integer, parameter :: lmmaxdm=(lmaxdm+1)**2
! density matrix in each muffin-tin
complex(8), allocatable :: dmatmt(:,:,:,:,:)
! potential matrix in each muffin-tin
complex(8), allocatable :: vmatmt(:,:,:,:,:)
! tvmatmt is .true. if the potential matrices are calculated
logical tvmatmt
! tvmmt is .true. if the potential matrix for that l and atom is non-zero
logical, allocatable :: tvmmt(:,:)
!-------------------------!
! DFT+U variables !
!-------------------------!
! type of DFT+U to use (0 = none)
integer dftu
! input type for DFT+U calculation (1:5)
integer inpdftu
! maximum number of DFT+U entries
integer, parameter :: maxdftu=40
! number of DFT+U entries
integer ndftu
! species and angular momentum for each entry
integer idftu(2,maxdftu)
! U and J values for each entry
real(8) ujdu(2,maxdftu)
! interpolation constant alpha for each atom and entry [PRB 67, 153106 (2003)]
real(8), allocatable :: alphadu(:,:)
! readadu is .true. if alphadu is to be read from file
logical readadu
! DFT+U energy for each atom and entry
real(8), allocatable :: engyadu(:,:)
! energy from the DFT+U correction
real(8) engydu
! Slater parameters
real(8) fdu(0:2*lmaxdm,maxdftu)
! Racah parameters
real(8) edu(0:lmaxdm,maxdftu)
! screening length of Yukawa potential to calculate Slater integrals
real(8) lambdadu(maxdftu)
! energies to calculate radial functions for Slater integrals
real(8), allocatable :: fdue(:,:)
! radial functions to calculate Slater integrals
real(8), allocatable :: fdufr(:,:,:)
! fixed value of U for which screening length has to be determined
real(8) udufix(maxdftu)
! initial values of screening length if U is fixed
real(8) lambdadu0(maxdftu)
!---------------------------------!
! tensor moment variables !
!---------------------------------!
! tmwrite is .true. if tensor moments are written out at every s.c. loop
logical tmwrite
! fixed tensor moment type
! 0 : none
! 2 (-2) : fixed 2-index tensor moment (or just lowering the symmetry)
! 3 (-3) : fixed 3-index tensor moment (or just lowering the symmetry)
integer ftmtype
! number of fixed tensor moment entries
integer ntmfix
! tensor moment indices for each entry: is, ia, l, n and k, p, x, y for the
! 2-index tensor or k, p, r, t for the 3-index tensor
integer, allocatable :: itmfix(:,:)
! tensor component
complex(8), allocatable :: tmfix(:)
! spatial and spin rotation matrices of tensor
real(8), allocatable :: rtmfix(:,:,:,:)
! density matrices corresponding to the fixed tensor moments
complex(8), allocatable :: dmftm(:,:,:,:,:)
! fixed tensor moment potential matrix
complex(8), allocatable :: vmftm(:,:,:,:,:)
! fixed tensor moment step size
real(8) tauftm
! number of self-consistent loops after which FTM field is updated
integer ftmstep
end module
elk-7.2.42/src/PaxHeaders.21776/modrdm.f90 0000644 0000000 0000000 00000000132 14061636516 014525 x ustar 00 30 mtime=1623670094.846102556
30 atime=1623670093.562103748
30 ctime=1623670094.846102556
elk-7.2.42/src/modrdm.f90 0000644 0025044 0025044 00000002132 14061636516 016560 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2008 S. Sharma, J. K. Dewhurst and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modrdm
use modmain
!--------------------------------------------------------------------!
! reduced density matrix functional theory (RDMFT) variables !
!--------------------------------------------------------------------!
! Coulomb potential matrix elements
complex(8), allocatable :: vclmat(:,:,:)
! derivative of kinetic energy w.r.t. natural orbital coefficients
complex(8), allocatable :: dkdc(:,:,:)
! step size for occupation numbers
real(8) taurdmn
! step size for natural orbital coefficients
real(8) taurdmc
! xc functional
integer rdmxctype
! maximum number of self-consistent loops
integer rdmmaxscl
! maximum number of iterations for occupation number optimisation
integer maxitn
! maximum number of iteration for natural orbital optimisation
integer maxitc
! exponent for the power and hybrid functional
real(8) rdmalpha
! temperature
real(8) rdmtemp
! entropy
real(8) rdmentrpy
end module
elk-7.2.42/src/PaxHeaders.21776/modphonon.f90 0000644 0000000 0000000 00000000132 14061636516 015244 x ustar 00 30 mtime=1623670094.847102555
30 atime=1623670093.564103746
30 ctime=1623670094.847102555
elk-7.2.42/src/modphonon.f90 0000644 0025044 0025044 00000012611 14061636516 017302 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modphonon
use modmain
!--------------------------!
! phonon variables !
!--------------------------!
! number of phonon branches (3*natmtot)
integer nbph
! current phonon q-point, species, atom and polarisation index
integer iqph,isph,iaph,iasph,ipph
! tphq0 is .true. if q = 0
logical tphq0
! number of vectors for writing out frequencies and eigenvectors
integer nphwrt
! vectors in lattice coordinates for writing out frequencies and eigenvectors
real(8), allocatable :: vqlwrt(:,:)
! Coulomb pseudopotential
real(8) mustar
! number of temperatures for the Eliashberg equations and thermal properties
integer ntemp
! phonon frequencies for all q-points
real(8), allocatable :: wphq(:,:)
!-----------------------------!
! supercell variables !
!-----------------------------!
! number of primitive unit cells in phonon supercell
integer nscph
! Cartesian offset vectors for each primitive cell in the supercell
real(8), allocatable :: vscph(:,:)
! phonon displacement distance
real(8) deltaph
!---------------------!
! k+q-vectors !
!---------------------!
! k+q-vectors in lattice coordinates
real(8), allocatable :: vkql(:,:)
! k+q-vectors in Cartesian coordinates
real(8), allocatable :: vkqc(:,:)
!------------------------------!
! G+q-vector variables !
!------------------------------!
! G+q-vectors in Cartesian coordinates
real(8), allocatable :: vgqc(:,:)
! G+q-vector lengths
real(8), allocatable :: gqc(:)
! regularised Coulomb Green's function in G+q-space
real(8), allocatable :: gclgq(:)
! spherical Bessel functions j_l(|G+q|R_mt)
real(8), allocatable :: jlgqrmt(:,:,:)
! spherical harmonics for G+q-vectors
complex(8), allocatable :: ylmgq(:,:)
! structure factors for G+q-vectors
complex(8), allocatable :: sfacgq(:,:)
! smooth step function form factors for all species and G+q-vectors
real(8), allocatable :: ffacgq(:,:)
! characteristic function derivative in G- and G+q-space
complex(8), allocatable :: dcfunig(:)
! characteristic function derivative in real-space
complex(8), allocatable :: dcfunir(:)
!--------------------------------!
! G+k+q-vector variables !
!--------------------------------!
! number of G+k+q-vector for each k-point
integer, allocatable :: ngkq(:,:)
! index from G+k+q-vectors to G-vectors
integer, allocatable :: igkqig(:,:,:)
! G+k+q-vectors in lattice and Cartesian coordinates
real(8), allocatable :: vgkql(:,:,:,:),vgkqc(:,:,:,:)
! G+k+q-vector lengths
real(8), allocatable :: gkqc(:,:,:)
! structure factors for the G+k+q-vectors
complex(8), allocatable :: sfacgkq(:,:,:,:)
!----------------------------------------------------------!
! density functional perturbation theory variables !
!----------------------------------------------------------!
! density derivative
complex(8), allocatable :: drhomt(:,:),drhoir(:)
! magnetisation derivative
complex(8), allocatable :: dmagmt(:,:,:),dmagir(:,:)
! Coulomb potential derivative
complex(8), allocatable :: dvclmt(:,:),dvclir(:)
! if tphdyn is .true. then the phonon dynamical matrix is being calculated
logical :: tphdyn=.false.
! nuclear potential without the self-term; used for the phonon dynamical matrix
complex(8), allocatable :: zvnmt(:)
! gradient of vsmt for the displaced muffin-tin
complex(8), allocatable :: gvsmt(:)
! combined target array for dvsmt, dvsir, dbsmt and dbsir
complex(8), allocatable, target :: dvsbs(:)
! Kohn-Sham potential derivative
complex(8), pointer :: dvsmt(:,:),dvsir(:)
! Kohn-Sham effective magnetic field derivative
complex(8), pointer :: dbsmt(:,:,:),dbsir(:,:)
! G+q-space interstitial Kohn-Sham potential derivative
complex(8), allocatable :: dvsig(:)
! spin-orbit coupling radial function derivative
complex(8), allocatable :: dsocfr(:,:)
! APW-APW Hamiltonian integral derivatives
complex(8), allocatable :: dhaa(:,:,:,:,:,:)
! local-orbital-APW Hamiltonian integral derivatives
complex(8), allocatable :: dhloa(:,:,:,:,:)
! local-orbital-local-orbital Hamiltonian integral derivatives
complex(8), allocatable :: dhlolo(:,:,:,:)
! real Gaunt coefficient array
real(8), allocatable :: gntyyy(:,:,:)
! smallest allowed perturbation theory denominator for eigenvector derivatives
real(8) epsdev
! Fermi energy derivative
real(8) defermi
! first-variational eigenvalue derivatives
real(8), allocatable :: devalfv(:,:,:)
! second-variational eigenvalue derivatives
real(8), allocatable :: devalsv(:,:)
! second-variational occupation number derivatives
real(8), allocatable :: doccsv(:,:)
!-------------------------------------------+
! electron-phonon mean-field theory |
!-------------------------------------------+
! energy change of the electron system
real(8) dengye
! energy change of the phonon system
real(8) dengyph
! sum of energy changes in electron and phonon systems
real(8) dengy
! phonon frequency cut-off below which modes are neglected
real(8) wphcut
! scale factor of the electron-phonon term and its mixing parameter
real(8) ephscf(2)
! anomalous is .true. if only the anomalous density matrix is to be used in the
! construction of the electron-phonon Hamiltonian
logical anomalous
! tephde is .true. if D = D0 + E, otherwise D = D0
logical tephde
! single-precision electron-phonon matrix element array for each k- and q-point
complex(4), allocatable :: ephmkq(:,:,:,:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/modtest.f90 0000644 0000000 0000000 00000000132 14061636516 014722 x ustar 00 30 mtime=1623670094.849102553
30 atime=1623670093.565103745
30 ctime=1623670094.849102553
elk-7.2.42/src/modtest.f90 0000644 0025044 0025044 00000004702 14061636516 016762 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2009 J. K. Dewhurst, S. Sharma and E. K. U. Gross
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modtest
use modmpi
! if test is .true. then the test variables are written to file
logical test
contains
subroutine writetest(id,descr,nv,iv,iva,tol,rv,rva,zv,zva)
implicit none
! arguments
integer, intent(in) :: id
character(*), intent(in) :: descr
integer, optional, intent(in) :: nv
integer, optional, intent(in) :: iv
integer, optional, intent(in) :: iva(*)
real(8), optional, intent(in) :: tol
real(8), optional, intent(in) :: rv
real(8), optional, intent(in) :: rva(*)
complex(8), optional, intent(in) :: zv
complex(8), optional, intent(in) :: zva(*)
! local variables
integer j
character(256) fname
if (.not.test) return
if (.not.mp_mpi) return
if ((id.lt.0).or.(id.gt.999)) then
write(*,*)
write(*,'("Error(writetest): id out of range : ",I8)') id
write(*,*)
stop
end if
if ((present(iva)).or.(present(rva)).or.(present(zva))) then
if (.not.present(nv)) then
write(*,*)
write(*,'("Error(writetest): missing argument nv")')
write(*,*)
stop
else
if (nv.le.0) then
write(*,*)
write(*,'("Error(writetest): nv <= 0 : ",I8)') nv
write(*,*)
stop
end if
end if
end if
if ((present(rv)).or.(present(rva)).or.(present(zv)).or.(present(zva))) then
if (.not.present(tol)) then
write(*,*)
write(*,'("Error(writetest): missing argument tol")')
write(*,*)
stop
end if
end if
write(fname,'("TEST_",I3.3,".OUT")') id
!$OMP CRITICAL(writetest_)
open(90,file=trim(fname),form='FORMATTED',action='WRITE')
write(90,'("''",A,"''")') trim(descr)
if (present(iv)) then
write(90,'(2I8)') 1,1
write(90,'(2I8)') 1,iv
else if (present(rv)) then
write(90,'(2I8)') 2,1
write(90,'(G22.12)') tol
write(90,'(I8,G22.12)') 1,rv
else if (present(zv)) then
write(90,'(2I8)') 3,1
write(90,'(G22.12)') tol
write(90,'(I8,2G22.12)') 1,dble(zv),aimag(zv)
else if (present(iva)) then
write(90,'(2I8)') 1,nv
do j=1,nv
write(90,'(2I8)') j,iva(j)
end do
else if (present(rva)) then
write(90,'(2I8)') 2,nv
write(90,'(G22.12)') tol
do j=1,nv
write(90,'(I8,G22.12)') j,rva(j)
end do
else if (present(zva)) then
write(90,'(2I8)') 3,nv
write(90,'(G22.12)') tol
do j=1,nv
write(90,'(I8,2G22.12)') j,dble(zva(j)),aimag(zva(j))
end do
end if
close(90)
!$OMP END CRITICAL(writetest_)
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/modrandom.f90 0000644 0000000 0000000 00000000132 14061636516 015223 x ustar 00 30 mtime=1623670094.851102551
30 atime=1623670093.567103743
30 ctime=1623670094.851102551
elk-7.2.42/src/modrandom.f90 0000644 0025044 0025044 00000002514 14061636516 017262 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2012 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modrandom
! random number generator state
integer(8) :: rndstate(0:5)=[799047353, 1322018920, 1014372120, 1198189977, &
832907020, 5678910]
contains
!BOP
! !ROUTINE: randomu
! !INTERFACE:
real(8) function randomu()
! !DESCRIPTION:
! Generates random numbers with a uniform distribution in the interval $[0,1]$
! using the fifth-order multiple recursive generator of P. L'Ecuyer,
! F. Blouin, and R. Coutre, {\it ACM Trans. Modeling Comput. Simulation}
! {\bf 3}, 87 (1993). The sequence of numbers $r_i$ is produced from
! $$ x_i=(a_1 x_{i-1}+a_5 x_{i-5})\mod m $$
! with $r_i=x_i/m$. The period is about $2^{155}$.
!
! !REVISION HISTORY:
! Created January 2012 (JKD)
! Changed initial state, April 2017 (JKD)
!EOP
!BOC
implicit none
! local variables
! parameters taken from the GNU Scientific Library (GSL)
integer(8), parameter :: a1=107374182, a5=104480, m=2147483647
integer(8) :: i=0
integer(8) i1,i5
!$OMP CRITICAL(randomu_)
i=modulo(i+1,6_8)
i1=modulo(i-1,6_8)
i5=modulo(i-5,6_8)
rndstate(i)=int(mod(a1*rndstate(i1)+a5*rndstate(i5),m))
randomu=dble(rndstate(i))/dble(m)
!$OMP END CRITICAL(randomu_)
end function
!EOC
end module
elk-7.2.42/src/PaxHeaders.21776/modstore.f90 0000644 0000000 0000000 00000000130 14061636516 015075 x ustar 00 29 mtime=1623670094.85210255
30 atime=1623670093.569103741
29 ctime=1623670094.85210255
elk-7.2.42/src/modstore.f90 0000644 0025044 0025044 00000002205 14061636516 017133 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2012 S. Sharma, J. K. Dewhurst and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!---------------------------------------------------------!
! variables for storing original input parameters !
!---------------------------------------------------------!
module modstore
use modmain
real(8) avec_(3,3)
real(8) bvec_(3,3),binv_(3,3)
real(8) omega_
logical tshift_
logical primcell_
integer natoms_(maxspecies)
integer natmtot_
integer idxis_(maxatoms*maxspecies)
real(8) atposl_(3,maxatoms,maxspecies)
real(8) atposc_(3,maxatoms,maxspecies)
integer ngridg_(3),ngtot_
integer, allocatable :: ivg_(:,:),igfft_(:)
logical spinpol_,spinorb_,cmagz_,spinsprl_
real(8) bfieldc0_(3)
real(8) bfcmt0_(3,maxatoms,maxspecies)
real(8) afieldc_(3)
real(8) reducebf_
integer fsmtype_
real(8) momfix_(3)
real(8) mommtfix_(3,maxatoms,maxspecies)
logical tforce_
logical autokpt_
integer ngridk_(3)
real(8) vkloff_(3)
integer lmaxi_
logical tfav0_
real(8) vqlss_(3)
integer msmooth_
integer reducek_
integer maxscl_
logical tjr_
real(8) swidth_
end module
elk-7.2.42/src/PaxHeaders.21776/modpw.f90 0000644 0000000 0000000 00000000132 14061636516 014371 x ustar 00 30 mtime=1623670094.854102548
30 atime=1623670093.571103739
30 ctime=1623670094.854102548
elk-7.2.42/src/modpw.f90 0000644 0025044 0025044 00000003202 14061636516 016423 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2012 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modpw
!----------------------------!
! H-vector variables !
!----------------------------!
! reduceh is .true. if the H-vectors are reduced with the crystal symmetries
logical reduceh
! H-vector cut-off for interstitial potential and density
real(8) hmaxvr
! H-vector grid sizes
integer ngridh(3)
! total number of H-vectors
integer nhtot
! integer grid intervals for each direction
integer inthv(2,3)
! number of H-vectors with |H| < hmaxvr
integer nhvec
! H-vector integer coordinates (i1,i2,i3)
integer, allocatable :: ivh(:,:)
! H-vector multiplicity after symmetry reduction
integer, allocatable :: mulh(:)
! H-vectors in Cartesian coordinates
real(8), allocatable :: vhc(:,:)
! length of H-vectors
real(8), allocatable :: hc(:)
! H-vector transformation matrix
real(8) vhmat(3,3)
!------------------------------!
! H+k-vector variables !
!------------------------------!
! maximum |H+k| cut-off for plane wave
real(8) hkmax
! number of H+k-vectors for plane waves
integer, allocatable :: nhk(:,:)
! maximum number of H+k-vectors over all k-points
integer nhkmax
! index from H+k-vectors to G-vectors
integer, allocatable :: ihkig(:,:,:)
! H+k-vectors in lattice coordinates
real(8), allocatable :: vhkl(:,:,:,:)
! H+k-vectors in Cartesian coordinates
real(8), allocatable :: vhkc(:,:,:,:)
! length of H+k-vectors
real(8), allocatable :: hkc(:,:,:)
! structure factors for the H+k-vectors
complex(8), allocatable :: sfachk(:,:,:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/modvars.f90 0000644 0000000 0000000 00000000132 14061636516 014716 x ustar 00 30 mtime=1623670094.855102548
30 atime=1623670093.572103738
30 ctime=1623670094.855102548
elk-7.2.42/src/modvars.f90 0000644 0025044 0025044 00000004650 14061636516 016760 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2011 J. K. Dewhurst, S. Sharma and E. K. U. Gross
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modvars
use modmpi
! if wrtvars is .true. then variables are written to VARIABLES.OUT
logical wrtvars
contains
subroutine delvars
implicit none
if (.not.mp_mpi) return
! delete existing variables file
open(95,file='VARIABLES.OUT')
close(95,status='DELETE')
end subroutine
subroutine writevars(vname,l,m,nv,iv,iva,rv,rva,zv,zva,sv,sva)
implicit none
! arguments
character(*), intent(in) :: vname
integer, optional, intent(in) :: l,m
integer, optional, intent(in) :: nv
integer, optional, intent(in) :: iv
integer, optional, intent(in) :: iva(*)
real(8), optional, intent(in) :: rv
real(8), optional, intent(in) :: rva(*)
complex(8), optional, intent(in) :: zv
complex(8), optional, intent(in) :: zva(*)
character(*), optional, intent(in) :: sv
character(*), optional, intent(in) :: sva(*)
! local variables
integer i
if (.not.wrtvars) return
if (.not.mp_mpi) return
if ((present(iva)).or.(present(rva)).or.(present(zva)).or.(present(sva))) then
if (.not.present(nv)) then
write(*,*)
write(*,'("Error(writevars): missing argument nv")')
write(*,*)
stop
else
if (nv.lt.0) then
write(*,*)
write(*,'("Error(writevars): nv < 0 : ",I8)') nv
write(*,*)
stop
end if
end if
end if
open(95,file='VARIABLES.OUT',position='APPEND',form='FORMATTED',action='WRITE')
write(95,*)
write(95,'(A)',advance='NO') trim(vname)
if (present(l)) write(95,'(I8)',advance='NO') l
if (present(m)) write(95,'(I8)',advance='NO') m
write(95,*)
if (present(iv)) then
write(95,'(2I8)') 1,1
write(95,'(I8)') iv
else if (present(rv)) then
write(95,'(2I8)') 2,1
write(95,'(G22.12)') rv
else if (present(zv)) then
write(95,'(2I8)') 3,1
write(95,'(2G22.12)') dble(zv),aimag(zv)
else if (present(sv)) then
write(95,'(2I8)') 4,1
write(95,'(A)') trim(sv)
else if (present(iva)) then
write(95,'(2I8)') 1,nv
do i=1,nv
write(95,'(I8)') iva(i)
end do
else if (present(rva)) then
write(95,'(2I8)') 2,nv
do i=1,nv
write(95,'(G22.12)') rva(i)
end do
else if (present(zva)) then
write(95,'(2I8)') 3,nv
do i=1,nv
write(95,'(2G22.12)') dble(zva(i)),aimag(zva(i))
end do
else if (present(sva)) then
write(95,'(2I8)') 4,nv
do i=1,nv
write(95,'(A)') trim(sva(i))
end do
end if
close(95)
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/modtddft.f90 0000644 0000000 0000000 00000000132 14061636516 015050 x ustar 00 30 mtime=1623670094.857102546
30 atime=1623670093.574103737
30 ctime=1623670094.857102546
elk-7.2.42/src/modtddft.f90 0000644 0025044 0025044 00000006077 14061636516 017117 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2010 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modtddft
!-----------------------------------------!
! TDDFT linear response variables !
!-----------------------------------------!
! exchange-correlation kernel type
integer fxctype(3)
! parameters for long-range correction (LRC) kernel
real(8) fxclrc(2)
! number of independent spin components of the f_xc spin tensor
integer nscfxc
! magnetic linear dichroism (MLD) angle between the electric and magnetic fields
real(8) thetamld
!---------------------------------------------!
! TDDFT real-time evolution variables !
!---------------------------------------------!
! number of laser pulses defining the time-dependent A-field
integer npulse
! laser pulse parameters: vector amplitude, peak time, full-width at
! half-maximum, frequency and phase
real(8), allocatable :: pulse(:,:)
! number of A-field ramps
integer nramp
! ramp parameters: vector amplitude, ramp start time, linear, quadratic, cubic,
! etc. coefficients
real(8), allocatable :: ramp(:,:)
! total simulation time
real(8) tstime
! time step length
real(8) dtimes
! number of time steps
integer ntimes
! current time step
integer itimes
! time steps
real(8), allocatable :: times(:)
! phase defining complex direction of time evolution
real(8) tdphi
! number of time steps after which the time-dependent eigenvectors are backed up
integer ntsbackup
! tafieldt is .true. if a time-dependent vector potential is applied
logical tafieldt
! time-dependent total A-field (external plus induced)
real(8), allocatable :: afieldt(:,:)
! induced A-field and its time derivative at the current time step
real(8) afindt(3,0:1)
! induced A-field scale factor
real(8) afindscf
! if tafindt is .true. then the induced A-field is determined from Maxwell's
! equation and added to the total
logical tafindt
! electric field at current time step
real(8) efieldt(3)
! observables are written to file every ntswrite(1) time steps; this begins
! at or after time step ntswrite(2); writing occurs at the first time step
! irrespective of ntswrite
integer ntswrite(2)
! static charge density
real(8), allocatable :: rhosmt(:,:,:),rhosir(:,:)
! total static charge
real(8) chgstot(3)
! muffin-tin static charge
real(8), allocatable :: chgsmt(:,:)
! gradient of the Coulomb potential of the nucleus plus static density
complex(8), allocatable :: gvclns(:,:,:)
! the following variables are .true. if the corresponding quantities are to be
! written every ntswrite time steps
logical tdrho1d,tdrho2d,tdrho3d
logical tdmag1d,tdmag2d,tdmag3d
logical tdjr1d,tdjr2d,tdjr3d
logical tddos,tdlsj
! magnitude of complex numbers added to initial eigenvectors
real(8) rndevt0
! starting time for the Fourier transform when calculating the linear response
! dielectric function from the real-time evolved current
real(8) t0tdlr
! number of time steps between force calculations
integer ntsforce
! total atomic forces at each time step
real(8), allocatable :: forcet(:,:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/modgw.f90 0000644 0000000 0000000 00000000132 14061636516 014360 x ustar 00 30 mtime=1623670094.858102545
30 atime=1623670093.576103735
30 ctime=1623670094.858102545
elk-7.2.42/src/modgw.f90 0000644 0025044 0025044 00000002427 14061636516 016422 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2016 A. Davydov, A. Sanna, J. K. Dewhurst, S. Sharma and
! E. K. U. Gross. This file is distributed under the terms of the GNU General
! Public License. See the file COPYING for license details.
module modgw
! maximum Matsubara frequency for the GW calculation
real(8) wmaxgw
! maximum number of Matsubara frequencies
integer nwgw
! integer grid intervals for Matsubara frequencies
integer intwgw(2)
! map from frequency index to FFT array
integer, allocatable :: iwfft(:)
! maximum fermionic Matsubara frequency index to be used for the GW calculation
integer nwfm
! maximum bosonic frequency index
integer nwbs
! imaginary frequencies used for the GW calculation
real(8), allocatable :: wgw(:)
! complex fermionic frequencies
complex(8), allocatable :: wfm(:)
! twdiag is .true. if the screened interaction W is taken to be diagonal
logical twdiag
! tsediag is .true. if the GW self-energy is taken to be diagonal
logical tsediag
! type of analytic continuation to be used for determining the self-energy on
! the real axis
integer actype
! number of poles used for fitting the self-energy matrix elements
integer npole
! number of complex shifts used in averaging the Pade approximant for the
! analytic continuation of the self-energy to the real axis
integer nspade
end module
elk-7.2.42/src/PaxHeaders.21776/modulr.f90 0000644 0000000 0000000 00000000132 14061636516 014545 x ustar 00 30 mtime=1623670094.860102543
30 atime=1623670093.577103734
30 ctime=1623670094.860102543
elk-7.2.42/src/modulr.f90 0000644 0025044 0025044 00000006265 14061636516 016613 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2017 T. Mueller, J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modulr
!-----------------------------!
! ultracell variables !
!-----------------------------!
! ultracell lattice vectors stored column-wise
real(8) avecu(3,3)
! ultracell reciprocal lattice vectors
real(8) bvecu(3,3)
! ultracell volume and Brillouin zone volume
real(8) omegau,omegabzu
! original number of k-points
integer nkpt0
! kappa-point grid sizes
integer ngridkpa(3)
! integer grid intervals for the kappa-points
integer intkpa(2,3)
! number of kappa-points
integer nkpa
! R-vectors in Cartesian coordinates spanning the ultracell
real(8), allocatable :: vrcu(:,:)
!------------------------------!
! G+Q-vector variables !
!------------------------------!
! small Q cut-off for non-zero Q-vectors
real(8) q0cut
! G+Q-vectors in Cartesian coordinates
real(8), allocatable :: vgqc(:,:,:)
! |G+Q| for all G+Q-vectors
real(8), allocatable :: gqc(:,:)
! Coulomb Green's function in G+Q-space = 4 pi / |G+Q|^2
real(8), allocatable :: gclgq(:,:)
! spherical Bessel functions j_l(|G+Q|R_mt)
real(8), allocatable :: jlgqrmt(:,:,:,:)
! spherical harmonics of the G+Q-vectors
complex(8), allocatable :: ylmgq(:,:,:)
! structure factors for the G+Q-vectors
complex(8), allocatable :: sfacgq(:,:,:)
! phase factor functions exp(iQ.r) in each muffin-tin
complex(8), allocatable :: expqmt(:,:,:)
!---------------------------------------------------!
! ultra long-range densities and potentials !
!---------------------------------------------------!
! trdvclr is .true. if the real-space external Coulomb potential should be read
! in from file
logical trdvclr
! Q-dependent external Coulomb potential (FFT ordering)
complex(8), allocatable :: vclq(:)
! Q-dependent external magnetic field
complex(8), allocatable :: bfcq(:,:)
! Q-dependent external muffin-tin magnetic fields
complex(8), allocatable :: bfcmtq(:,:,:)
! electric field vector in Cartesian coordinates
real(8) efielduc(3)
! R-dependent density and magnetisation
real(8), allocatable :: rhormt(:,:,:),rhorir(:,:)
real(8), allocatable :: magrmt(:,:,:,:),magrir(:,:,:)
! muffin-tin charges and moments for each R-vector
real(8), allocatable :: chgmtru(:,:)
real(8), allocatable :: mommtru(:,:,:)
! Q-dependent density and magnetisation
complex(8), allocatable :: rhoqmt(:,:,:),rhoqir(:,:)
complex(8), allocatable :: magqmt(:,:,:,:),magqir(:,:,:)
! Q-dependent Kohn-Sham potential and magnetic field
complex(8), allocatable, target :: vsbsq(:)
complex(8), pointer :: vsqmt(:,:,:),vsqir(:,:)
complex(8), pointer :: bsqmt(:,:,:,:),bsqir(:,:,:)
! random amplitude used for initialising the long-range magnetic field
real(8) rndbfcu
! if tplotq0 is .true. then the Q=0 term is included when generating plots
logical tplotq0
!----------------------------------------------!
! eigenvalue and eigenvector variables !
!----------------------------------------------!
! number of ultra long-range states
integer nstulr
! long-range eigenvalues
real(8), allocatable :: evalu(:,:)
! long-range occupation numbers
real(8), allocatable :: occulr(:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/modbog.f90 0000644 0000000 0000000 00000000132 14061636516 014512 x ustar 00 30 mtime=1623670094.861102542
30 atime=1623670093.579103732
30 ctime=1623670094.861102542
elk-7.2.42/src/modbog.f90 0000644 0025044 0025044 00000002312 14061636516 016545 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2019 J. K. Dewhurst and S. Sharma.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modbog
! combined target array for fermionic and bosonic density matrices
complex(8), allocatable, target :: duvwx(:)
!----------------------------------------!
! fermionic Bogoliubov variables !
!----------------------------------------!
! Bogoliubov equation eigenvalues
real(8), allocatable :: evaluv(:,:)
! V-norm for each state and k-point
real(8), allocatable :: vnorm(:,:)
! Fermi energy adjustment step size
real(8) tauefm
! Fermi energy convergence tolerance
real(8) epsefm
! Hartree-Fock-Bogoliubov coupling constant
real(8) ehfb
! density matrices VV† and UV†
complex(8), pointer :: dvv(:,:,:),duv(:,:,:)
! fermionic anomalous correlation entropy
real(8) face
! bdiag is .true. if the matrix B is taken to be diagonal
logical bdiag
!--------------------------------------!
! bosonic Bogoliubov variables !
!--------------------------------------!
! Bogoliubov equation eigenvalues
real(8), allocatable :: evalwx(:,:)
! density matrices XX† and WX†
complex(8), pointer :: dxx(:,:,:),dwx(:,:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/moddelf.f90 0000644 0000000 0000000 00000000127 14061636516 014661 x ustar 00 29 mtime=1623670094.86310254
29 atime=1623670093.58110373
29 ctime=1623670094.86310254
elk-7.2.42/src/moddelf.f90 0000644 0025044 0025044 00000005170 14061636516 016715 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2020 J. K. Dewhurst and S. Sharma.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module moddelf
use modramdisk
use modmpi
contains
subroutine delfiles(evec,devec,eval,occ,pmat,epsi)
use modphonon
implicit none
! arguments
logical, optional, intent(in) :: evec,devec,eval,occ,pmat,epsi
! local variables
integer ios
character(256) fext,fname
if (present(evec)) then
! delete the first-variational eigenvector file
fname=trim(scrpath)//'EVECFV'//trim(filext)
if (mp_mpi) then
open(202,file=fname,form='UNFORMATTED',iostat=ios)
close(202,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd(fname)
! delete the second-variational eigenvector file
fname=trim(scrpath)//'EVECSV'//trim(filext)
if (mp_mpi) then
open(206,file=fname,form='UNFORMATTED',iostat=ios)
close(206,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd(fname)
end if
if (present(devec)) then
! construct the dynamical matrix file extension
call dynfext(iqph,isph,iaph,ipph,fext)
! delete the eigenvector derivative files
fname=trim(scrpath)//'DEVECFV'//trim(fext)
if (mp_mpi) then
open(222,file=fname,form='UNFORMATTED',iostat=ios)
close(222,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd(fname)
fname=trim(scrpath)//'DEVECSV'//trim(fext)
if (mp_mpi) then
open(226,file=fname,form='UNFORMATTED',iostat=ios)
close(226,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd(fname)
end if
if (present(eval)) then
! delete the first-variational eigenvalue file
fname='EVALFV'//trim(filext)
if (mp_mpi) then
open(200,file=fname,form='UNFORMATTED',iostat=ios)
close(200,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd(fname)
! delete the second-variational eigenvalue file
if (mp_mpi) then
open(204,file='EVALSV'//trim(filext),form='UNFORMATTED',iostat=ios)
close(204,status='DELETE',iostat=ios)
end if
end if
if (present(occ)) then
! delete the occupation number file
if (mp_mpi) then
open(208,file='OCCSV'//trim(filext),form='UNFORMATTED',iostat=ios)
close(208,status='DELETE',iostat=ios)
end if
end if
if (present(pmat)) then
! delete the momentum matrix elements file
if (mp_mpi) then
open(230,file='PMAT.OUT',form='UNFORMATTED',iostat=ios)
close(230,status='DELETE',iostat=ios)
end if
if (ramdisk) call delfrd('PMAT.OUT')
end if
if (present(epsi)) then
! delete the inverse epsilon file
if (mp_mpi) then
open(245,file='EPSINV.OUT',form='UNFORMATTED',iostat=ios)
close(245,status='DELETE',iostat=ios)
end if
end if
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/modomp.f90 0000644 0000000 0000000 00000000132 14061636516 014536 x ustar 00 30 mtime=1623670094.864102539
30 atime=1623670093.582103729
30 ctime=1623670094.864102539
elk-7.2.42/src/modomp.f90 0000644 0025044 0025044 00000007350 14061636516 016600 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
module modomp
! maximum number of OpenMP threads available
integer maxthd
! maximum number of OpenMP threads for the first nesting level
integer maxthd1
! maximum number of threads available to MKL
integer maxthdmkl
! maximum OpenMP nesting level
integer maxlvl
! number of active OpenMP threads for each nesting level
integer, allocatable, protected :: nathd(:)
interface
integer function omp_get_num_procs()
end function
integer function omp_get_max_threads()
end function
integer function omp_get_num_threads()
end function
integer function omp_get_thread_num()
end function
integer function omp_get_max_active_levels()
end function
logical function omp_get_dynamic()
end function
integer function omp_get_level()
end function
subroutine omp_set_num_threads(num_threads)
integer, intent(in) :: num_threads
end subroutine
integer function mkl_set_num_threads_local(num_threads)
integer, intent(in) :: num_threads
end function
subroutine omp_set_nested(nested)
logical, intent(in) :: nested
end subroutine
subroutine omp_set_max_active_levels(max_levels)
integer, intent(in) :: max_levels
end subroutine
subroutine omp_set_dynamic(dynamic_threads)
logical, intent(in) :: dynamic_threads
end subroutine
end interface
contains
subroutine omp_init
implicit none
! determine the maximum number of available threads
select case(maxthd)
case(:-1)
! set the number of threads equal to a fraction of the number of processors
maxthd=omp_get_num_procs()/abs(maxthd)
maxthd=max(maxthd,1)
call omp_set_num_threads(maxthd)
case(0)
! use the system default number of threads
maxthd=omp_get_max_threads()
case default
! use the number of threads specified in the input file
call omp_set_num_threads(maxthd)
end select
! determine the maximum number of threads available at first nesting level
select case(maxthd1)
case(:-1)
maxthd1=maxthd/abs(maxthd1)
maxthd1=max(maxthd1,1)
case(0)
maxthd1=maxthd
case default
maxthd1=min(maxthd1,maxthd)
end select
! switch off dynamic allocation of threads
call omp_set_dynamic(.false.)
! allow nested parallelism (deprecated in OpenMP version 5)
call omp_set_nested(.true.)
! set the maximum nesting level
call omp_set_max_active_levels(maxlvl)
! allocate the number of active threads array
if (allocated(nathd)) deallocate(nathd)
allocate(nathd(0:maxlvl))
! initialise the number of active threads
call omp_reset
end subroutine
subroutine omp_reset
implicit none
! number of active threads at each nesting level
nathd(0)=1
nathd(1:)=0
end subroutine
subroutine holdthd(nloop,nthd)
implicit none
! arguments
integer, intent(in) :: nloop
integer, intent(out) :: nthd
! local variables
integer lvl,na,n
! current nesting level
lvl=omp_get_level()
if ((lvl.lt.0).or.(lvl.ge.maxlvl)) then
nthd=1
return
end if
!$OMP CRITICAL(modomp_)
! determine number of active threads at the current nesting level
na=nathd(lvl)
na=max(min(na,maxthd),1)
! number of threads allowed for this loop
nthd=maxthd/na
if (mod(maxthd,na).gt.0) nthd=nthd+1
if (lvl.eq.0) nthd=min(nthd,maxthd1)
nthd=max(min(nthd,maxthd,nloop),1)
! add to number of active threads in next nesting level
n=nathd(lvl+1)+nthd
n=max(min(n,maxthd),0)
nathd(lvl+1)=n
!$OMP END CRITICAL(modomp_)
end subroutine
subroutine freethd(nthd)
implicit none
! arguments
integer, intent(in) :: nthd
! local variables
integer lvl,n
! current nesting level
lvl=omp_get_level()
if ((lvl.lt.0).or.(lvl.ge.maxlvl)) return
!$OMP CRITICAL(modomp_)
! subtract from the number of active threads in next nesting level
n=nathd(lvl+1)-nthd
n=max(min(n,maxthd),0)
nathd(lvl+1)=n
!$OMP END CRITICAL(modomp_)
end subroutine
end module
elk-7.2.42/src/PaxHeaders.21776/mkl_stub.f90 0000644 0000000 0000000 00000000132 14061636517 015064 x ustar 00 30 mtime=1623670095.970101513
30 atime=1623670093.584103727
30 ctime=1623670095.970101513
elk-7.2.42/src/mkl_stub.f90 0000644 0025044 0025044 00000001077 14061636517 017126 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for Intel MKL
subroutine mkl_set_num_threads(num_threads)
implicit none
integer, intent(in) :: num_threads
end subroutine
integer function mkl_set_num_threads_local(num_threads)
implicit none
integer, intent(in) :: num_threads
mkl_set_num_threads_local=0
end function
subroutine mkl_set_dynamic(dynamic)
implicit none
logical, intent(in) :: dynamic
end subroutine
elk-7.2.42/src/PaxHeaders.21776/mkl_init.f90 0000644 0000000 0000000 00000000132 14061636516 015051 x ustar 00 30 mtime=1623670094.867102536
30 atime=1623670093.586103725
30 ctime=1623670094.867102536
elk-7.2.42/src/mkl_init.f90 0000644 0025044 0025044 00000001176 14061636516 017113 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine mkl_init
use modomp
implicit none
! set the initial global number of MKL threads equal to one
call mkl_set_num_threads(1)
! set the maximum number of threads available to MKL
select case(maxthdmkl)
case(:-1)
maxthdmkl=maxthd/abs(maxthdmkl)
maxthdmkl=max(maxthdmkl,1)
case(0)
maxthdmkl=maxthd
case default
maxthdmkl=min(maxthdmkl,maxthd)
end select
! enable dynamic thread allocation
call mkl_set_dynamic(.true.)
end subroutine
elk-7.2.42/src/PaxHeaders.21776/oblas_stub.f90 0000644 0000000 0000000 00000000132 14061636517 015401 x ustar 00 30 mtime=1623670095.972101511
30 atime=1623670093.587103725
30 ctime=1623670095.972101511
elk-7.2.42/src/oblas_stub.f90 0000644 0025044 0025044 00000000517 14061636517 017441 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for OpenBLAS
subroutine openblas_set_num_threads(num_threads)
implicit none
integer, intent(in) :: num_threads
end subroutine
elk-7.2.42/src/PaxHeaders.21776/oblas_init.f90 0000644 0000000 0000000 00000000132 14061636516 015366 x ustar 00 30 mtime=1623670094.870102534
30 atime=1623670093.589103723
30 ctime=1623670094.870102534
elk-7.2.42/src/oblas_init.f90 0000644 0025044 0025044 00000000516 14061636516 017425 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine oblas_init
implicit none
! set the initial number of OpenBLAS threads equal to one
call openblas_set_num_threads(1)
end subroutine
elk-7.2.42/src/PaxHeaders.21776/blis_stub.f90 0000644 0000000 0000000 00000000130 14061636517 015230 x ustar 00 29 mtime=1623670095.97310151
30 atime=1623670093.591103721
29 ctime=1623670095.97310151
elk-7.2.42/src/blis_stub.f90 0000644 0025044 0025044 00000000515 14061636517 017270 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for BLIS
subroutine bli_thread_set_num_threads(num_threads)
implicit none
integer, intent(in) :: num_threads
end subroutine
elk-7.2.42/src/PaxHeaders.21776/blis_init.f90 0000644 0000000 0000000 00000000131 14061636516 015216 x ustar 00 30 mtime=1623670094.873102531
29 atime=1623670093.59210372
30 ctime=1623670094.873102531
elk-7.2.42/src/blis_init.f90 0000644 0025044 0025044 00000000513 14061636516 017253 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine blis_init
implicit none
! set the initial number of BLIS threads equal to one
call bli_thread_set_num_threads(1)
end subroutine
elk-7.2.42/src/PaxHeaders.21776/w90_stub.f90 0000644 0000000 0000000 00000000132 14061636517 014720 x ustar 00 30 mtime=1623670095.975101508
30 atime=1623670093.594103718
30 ctime=1623670095.975101508
elk-7.2.42/src/w90_stub.f90 0000644 0025044 0025044 00000003221 14061636517 016753 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2017-18 Arsenii Gerasimov, Yaroslav Kvashnin and Lars Nordstrom.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! Stub routines for Wannier90 library.
subroutine wannier_setup(seed__name,mp_grid_loc,num_kpts_loc, &
real_lattice_loc,recip_lattice_loc,kpt_latt_loc,num_bands_tot, &
num_atoms_loc,atom_symbols_loc,atoms_cart_loc, gamma_only_loc,spinors_loc, &
nntot_loc,nnlist_loc,nncell_loc,num_bands_loc,num_wann_loc, &
proj_site_loc,proj_l_loc,proj_m_loc,proj_radial_loc,proj_z_loc, &
proj_x_loc,proj_zona_loc,exclude_bands_loc,proj_s_loc,proj_s_qaxis_loc)
implicit none
! arguments
character(*) seed__name
integer mp_grid_loc(3)
integer num_kpts_loc
real(8) real_lattice_loc(3,3)
real(8) recip_lattice_loc(3,3)
real(8) kpt_latt_loc(3,num_kpts_loc)
integer num_bands_tot
integer num_atoms_loc
character(*) atom_symbols_loc(num_atoms_loc)
real(8) atoms_cart_loc(3,num_atoms_loc)
logical gamma_only_loc
logical spinors_loc
integer nntot_loc
integer nnlist_loc(num_kpts_loc,*)
integer nncell_loc(3,num_kpts_loc,*)
integer num_bands_loc
integer num_wann_loc
real(8) proj_site_loc(3,num_bands_tot)
integer proj_l_loc(num_bands_tot)
integer proj_m_loc(num_bands_tot)
integer proj_radial_loc(num_bands_tot)
real(8) proj_z_loc(3,num_bands_tot)
real(8) proj_x_loc(3,num_bands_tot)
real(8) proj_zona_loc(num_bands_tot)
integer exclude_bands_loc(num_bands_tot)
integer, optional :: proj_s_loc(num_bands_tot)
real(8), optional :: proj_s_qaxis_loc(3,num_bands_tot)
write(*,*)
write(*,'("Error(wannier_setup): libwannier not or improperly installed")')
write(*,*)
error stop
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/modw90.f90 0000644 0000000 0000000 00000000132 14061636516 014362 x ustar 00 30 mtime=1623670094.876102528
30 atime=1623670093.596103716
30 ctime=1623670094.876102528
elk-7.2.42/src/modw90.f90 0000644 0025044 0025044 00000002274 14061636516 016424 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2015 Jon Lafuente and Manh Duc Le; 2017-18 Arsenii Gerasimov,
! Yaroslav Kvashnin and Lars Nordstrom. This file is distributed under the terms
! of the GNU General Public License. See the file COPYING for license details.
module modw90
!---------------------------------------!
! Wannier90 interface variables !
!---------------------------------------!
! seedname for all Wannier90 files
character(256) seedname
! number of extra lines to write to .win file
integer nxlwin
! extra lines to write to .win file
character(256), allocatable :: xlwin(:)
! number of Wannier functions to calculate
integer num_wann
! number of bands to pass to Wannier90
integer num_bands
! index to bands
integer, allocatable :: idxw90(:)
! number of iterations for the minimisation of omega
integer num_iter
! trial step for the line search minimisation
real(8) trial_step
! maximum number of nearest neighbours per k-point
integer, parameter :: num_nnmax=12
! total number of nearest neighbours for each k-point
integer nntot
! list of nearest neighbours for each k-point
integer, allocatable :: nnlist(:,:)
! G-vector offset for each nearest neighbour
integer, allocatable :: nncell(:,:,:)
end module
elk-7.2.42/src/PaxHeaders.21776/zfftifc.f90 0000644 0000000 0000000 00000000130 14061636517 014675 x ustar 00 29 mtime=1623670095.99410149
30 atime=1623670093.597103715
29 ctime=1623670095.99410149
elk-7.2.42/src/zfftifc.f90 0000644 0025044 0025044 00000002347 14061636517 016742 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: zfftifc
! !INTERFACE:
subroutine zfftifc(nd,n,sgn,z)
! !INPUT/OUTPUT PARAMETERS:
! nd : number of dimensions (in,integer)
! n : grid sizes (in,integer(nd))
! sgn : FFT direction, -1: forward; 1: backward (in,integer)
! z : array to transform (inout,complex(n(1)*n(2)*...*n(nd)))
! !DESCRIPTION:
! Interface to the double-precision complex fast Fourier transform routine.
! This is to allow machine-optimised routines to be used without affecting the
! rest of the code. See routine {\tt nfftifc}.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: nd,n(nd),sgn
complex(8), intent(inout) :: z(*)
! interface to modified FFTPACK5
call cfftnd(nd,n,sgn,z)
end subroutine
!EOC
subroutine rzfftifc(nd,n,sgn,r,z)
implicit none
! arguments
integer, intent(in) :: nd,n(nd),sgn
real(8), intent(inout) :: r(*)
complex(8), intent(inout) :: z(*)
write(*,*)
write(*,'("Error(rzfftifc): FFTW or MKL required for real to complex FFT")')
write(*,*)
stop
end subroutine
elk-7.2.42/src/PaxHeaders.21776/elk.f90 0000644 0000000 0000000 00000000132 14061636516 014016 x ustar 00 30 mtime=1623670094.880102524
30 atime=1623670093.599103713
30 ctime=1623670094.880102524
elk-7.2.42/src/elk.f90 0000644 0025044 0025044 00000246227 14061636516 016070 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2011 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
! main routine for the Elk code
program elk
use modmain
use modmpi
use modomp
use modvars
use modramdisk
implicit none
! local variables
logical exist
integer itask
! initialise MPI execution environment
call mpi_init(ierror)
! duplicate mpi_comm_world
call mpi_comm_dup(mpi_comm_world,mpicom,ierror)
! determine the number of MPI processes
call mpi_comm_size(mpicom,np_mpi,ierror)
! determine the local MPI process number
call mpi_comm_rank(mpicom,lp_mpi,ierror)
! determine if the local process is the master
if (lp_mpi.eq.0) then
mp_mpi=.true.
write(*,*)
write(*,'("Elk code version ",I1.1,".",I1.1,".",I2.2," started")') version
else
mp_mpi=.false.
end if
! read input files
call readinput
! initialise OpenMP variables
call omp_init
! initialise the MKL library
call mkl_init
! initialise the OpenBLAS library
call oblas_init
! initialise the BLIS library
call blis_init
if (mp_mpi) then
write(*,*)
write(*,'("Number of MPI processes : ",I6)') np_mpi
write(*,'("Number of OpenMP threads per MPI process : ",I4)') maxthd
write(*,'("Total number of threads (MPI x OpenMP) : ",I6)') np_mpi*maxthd
write(*,'("Maximum OpenMP nesting level : ",I4)') maxlvl
write(*,'("Number of OpenMP threads at first nesting level : ",I4)') maxthd1
write(*,'("Number of MKL threads : ",I4)') maxthdmkl
end if
! delete the VARIABLES.OUT file
call delvars
! write version number to VARIABLES.OUT
call writevars('version',nv=3,iva=version)
! check if Elk is already running in this directory
if (mp_mpi) then
inquire(file='RUNNING',exist=exist)
if (exist) then
write(*,*)
write(*,'("Info(elk): several copies of Elk may be running in this path")')
write(*,'("(this could be intentional, or result from a previous crash,")')
write(*,'(" or arise from an incorrect MPI compilation)")')
else
open(50,file='RUNNING')
close(50)
end if
end if
! initialise the RAM disk if required
if (ramdisk) then
call initrd
if (mp_mpi) then
write(*,*)
write(*,'("RAM disk enabled")')
end if
end if
! perform the tasks
do itask=1,ntasks
task=tasks(itask)
if (mp_mpi) then
write(*,*)
write(*,'("Info(elk): current task : ",I6)') task
end if
! synchronise MPI processes
call mpi_barrier(mpicom,ierror)
! check if task can be run with MPI
if (lp_mpi.gt.0) then
if (any(task.eq.[0,1,2,3,5,15,16,28,29,61,62,63,110,120,135,136,162,170, &
180,185,188,200,201,205,208,240,241,270,271,300,320,330,331,350,351,371, &
372,373,440,460,461,462,463,471,478,600,610,620,630,640,700,701,800, &
801])) then
continue
else
write(*,'("Info(elk): MPI process ",I6," idle for task ",I6)') lp_mpi,task
cycle
end if
end if
! write task to VARIABLES.OUT
call writevars('task',iv=task)
select case(task)
case(0,1)
call gndstate
case(2,3)
call geomopt
case(5)
call hartfock
case(10)
call writedos
case(14)
call writesf
case(15,16)
call writelsj
case(20,21,22,23)
call bandstr
case(25)
call effmass
case(28,29)
call mae
case(31,32,33)
call rhoplot
case(41,42,43)
call potplot
case(51,52,53)
call elfplot
case(61,62,63,162)
call wfplot
case(65)
call wfcrplot
case(68)
call rdstatus
case(71,72,73,81,82,83,141,142,143,151,152,153)
call vecplot
case(91,92,93)
call dbxcplot
case(100,101)
call fermisurf
case(102)
call fermisurfbxsf
case(105)
call nesting
case(110)
call mossbauer
case(115)
call writeefg
case(120)
call writepmat
case(121)
call dielectric
case(122)
call moke
case(125)
call nonlinopt
case(130)
call writeexpmat
case(135)
call writewfpw
case(140)
call elnes
case(150)
call writeevsp
case(160)
call torque
case(170)
call writeemd
case(171,172,173)
call emdplot
case(180)
call writeepsinv
case(185)
call writehmlbse
case(186)
call writeevbse
case(187)
call dielectric_bse
case(190)
call geomplot
case(195)
call sfacrho
case(196)
call sfacmag
case(200,201,202)
call phononsc
case(205)
call phonon
case(208,209)
call bornechg
case(210)
call phdos
case(220)
call phdisp
case(230)
call writephn
case(240,241)
call ephcouple
case(245)
call phlwidth
case(250)
call alpha2f
case(260)
call eliashberg
case(270,271)
call gndsteph
case(280)
call ephdos
case(285)
call aceplot
case(300)
call rdmft
case(320)
call tddftlr
case(330,331)
call tddftsplr
case(341,342,343)
call wxcplot
case(350,351,352)
call spiralsc
case(371,372,373)
call jprplot
case(400)
call writetmdu
case(430)
call writestrain
case(440)
call writestress
case(450)
call genafieldt
case(460,461,462,463)
call tddft
case(471)
call rhosplot
case(478)
call bornectd
case(480,481)
call dielectric_tdrt
case(500)
call testcheck
case(550)
call writew90
case(600)
call gwsefm
case(610)
call gwspecf
case(620)
call gwbandstr
case(630)
call gwscrho
case(640)
call gwdmat
case(700,701)
call gndstulr
case(731,732,733)
call rhouplot
case(741,742,743)
call potuplot
case(771,772,773)
call maguplot
case(800,801)
!***********
case default
write(*,*)
write(*,'("Error(elk): task not defined : ",I8)') task
write(*,*)
stop
end select
! reset the OpenMP thread variables
call omp_reset
! close all opened files
call closefiles
end do
if (mp_mpi) then
open(50,file='RUNNING')
close(50,status='DELETE')
write(*,*)
write(*,'("Elk code stopped")')
end if
! terminate MPI execution environment
call mpi_finalize(ierror)
end program
!BOI
! !TITLE: {\huge{\sc The Elk Code Manual}}\\ \Large{\sc Version 7.2.42}\\ \vskip 20pt \includegraphics[height=1cm]{elk_silhouette.pdf}
! !AUTHORS: {\sc J. K. Dewhurst, S. Sharma} \\ {\sc L. Nordstr\"{o}m, F. Cricchio, O. Gr\aa n\"{a}s} \\ {\sc E. K. U. Gross}
! !AFFILIATION:
! !INTRODUCTION: Introduction
! Welcome to the Elk Code! Elk is an all-electron full-potential linearised
! augmented-plane-wave (FP-LAPW) code for determining the properties of
! crystalline solids. It was developed originally at the
! Karl-Franzens-Universit\"{a}t Graz as part of the EXCITING EU Research and
! Training Network project\footnote{EXCITING code developed under the Research
! and Training Network EXCITING funded by the EU, contract No.
! HPRN-CT-2002-00317}. The guiding philosophy during the implementation of the
! code was to keep it as simple as possible for both users and developers
! without compromising on its capabilities. All the routines are released
! under either the GNU General Public License (GPL) or the GNU Lesser General
! Public License (LGPL) in the hope that they may inspire other scientists to
! implement new developments in the field of density functional theory and
! beyond.
!
! \section{Acknowledgments}
! Lots of people contributed to the Elk code with ideas, checking and testing,
! writing code or documentation and general encouragement. They include
! Claudia Ambrosch-Draxl, Clas Persson, Fredrik Bultmark, Christian Brouder,
! Rickard Armiento, Andrew Chizmeshya, Per Anderson, Igor Nekrasov, Sushil
! Auluck, Frank Wagner, Fateh Kalarasse, J\"{u}rgen Spitaler, Stefano
! Pittalis, Nektarios Lathiotakis, Tobias Burnus, Stephan Sagmeister,
! Christian Meisenbichler, S\'{e}bastien Leb\`{e}gue, Yigang Zhang, Fritz
! K\"{o}rmann, Alexey Baranov, Anton Kozhevnikov, Shigeru Suehara, Frank
! Essenberger, Antonio Sanna, Tyrel McQueen, Tim Baldsiefen, Marty Blaber,
! Anton Filanovich, Torbj\"{o}rn Bj\"{o}rkman, Martin Stankovski, Jerzy
! Goraus, Markus Meinert, Daniel Rohr, Vladimir Nazarov, Kevin Krieger, Pink
! Floyd, Arkardy Davydov, Florian Eich, Aldo Romero Castro, Koichi Kitahara,
! James Glasbrenner, Konrad Bussmann, Igor Mazin, Matthieu Verstraete, David
! Ernsting, Stephen Dugdale, Peter Elliott, Marcin Dulak, Jos\'{e} A. Flores
! Livas, Stefaan Cottenier, Yasushi Shinohara, Michael Fechner, Yaroslav
! Kvashnin, Tristan M\"uller, Arsenii Gerasimov, Manh Duc Le, Jon Lafuente
! Bartolom\'{e}, Ren\'{e} Wirnata, Jagdish Kumar, Andrew Shyichuk, Nisha
! Singh, Pietro Bonfa, Ronald Cohen and Alyn James. Special mention of David
! Singh's very useful book on the LAPW method\footnote{D. J. Singh,
! {\it Planewaves, Pseudopotentials and the LAPW Method} (Kluwer Academic
! Publishers, Boston, 1994).} must also be made. Finally we would like to
! acknowledge the generous support of Karl-Franzens-Universit\"{a}t Graz, the
! EU Marie-Curie Research Training Networks initiative, the Max Born Institute
! and the Max Planck Society.
!
! \vspace{24pt}
! Kay Dewhurst\newline
! Sangeeta Sharma\newline
! Lars Nordstr\"{o}m\newline
! Francesco Cricchio\newline
! Oscar Gr\aa n\"{a}s\newline
! Hardy Gross
!
! \vspace{12pt}
! Berlin, Halle, Jerusalem and Uppsala, June 2021
! \newpage
!
! \section{Units}
! Unless explicitly stated otherwise, Elk uses atomic units. In this system
! $\hbar=1$, the electron mass $m=1$, the Bohr radius $a_0=1$ and the electron
! charge $e=1$ (note that the electron charge is positive, so that the atomic
! numbers $Z$ are negative). Thus the atomic unit of length is
! 0.529177210903(80) \AA, and the atomic unit of energy is the Hartree which
! equals 27.211386245988(53) eV. The unit of the external magnetic fields is
! defined such that one unit of magnetic field in {\tt elk.in} equals
! 1715.255541 Tesla.
!
! \section{Compiling and running Elk}
! \subsection{Compiling the code}
! Unpack the code from the archive file. Run the command
! \begin{verbatim}
! setup
! \end{verbatim}
! in the {\tt elk} directory and select the appropriate system and compiler.
! We highly recommend that you edit the file {\tt make.inc} and tune the
! compiler options for your computer system. In particular, use of
! machine-optimised BLAS/LAPACK libraries can result in significant increase
! in performance, but make sure they are of version $3.x$. Following this, run
! \begin{verbatim}
! make
! \end{verbatim}
! This will hopefully compile the entire code and all the libraries into one
! executable, {\tt elk}, located in the {\tt elk/src} directory. It will also
! compile two useful auxiliary programs, namely {\tt spacegroup} for producing
! crystal geometries from spacegroup data and {\tt eos} for fitting equations
! of state to energy-volume data. If you want to compile everything all over
! again, then run {\tt make clean} from the {\tt elk} directory, followed by
! {\tt make}.
! \subsubsection{Parallelism in Elk}
! Three forms of parallelism are implemented in Elk, and all can be used in
! combination with each other, with efficiency depending on the particular
! task, crystal structure and computer system. You may need to contact your
! system administrator for assistance with running Elk in parallel.
! \begin{enumerate}
! \item
! OpenMP works for symmetric multiprocessors, i.e. computers that have many
! cores with the same unified memory accessible to each. It is enabled by
! setting the appropriate command-line options (e.g. {\tt -qopenmp} for the
! Intel compiler) before compiling, and also at runtime by the environment
! variable
! \begin{verbatim}
! export OMP_NUM_THREADS=n
! \end{verbatim}
! where n is the number of cores available on a particular node. The same can
! be accomplished in {\tt elk.in} with
! \begin{verbatim}
! maxthd
! n
! \end{verbatim}
! In addition, some vendor-supplied BLAS/LAPACK libraries use OpenMP
! internally. The maximum number of threads used for LAPACK operations by
! Intel's MKL can be set with
! \begin{verbatim}
! maxthdmkl
! n
! \end{verbatim}
! \item
! The message passing interface (MPI) is particularly suitable for running
! Elk across multiple nodes of a cluster, with scaling to hundreds of
! processors possible. To enable MPI, comment out the lines indicated in
! {\tt elk/make.inc}. Then run {\tt make clean} followed by {\tt make}. If
! $y$ is the number of nodes and $x$ is the number of cores per node, then at
! runtime envoke
! \begin{verbatim}
! mpirun -np z ./elk
! \end{verbatim}
! where $z=x y$ is the total number of cores available on the machine.
! Highest efficiency is obtained by using hybrid parallelism with OpenMP on
! each node and MPI across nodes. This can be done by compiling the code
! using the MPI Fortran compiler in combination with the OpenMP command-line
! option. At runtime set {\tt export OMP\_NUM\_THREADS=x} and start the MPI
! run with {\em one process per node} as follows
! \begin{verbatim}
! mpirun -pernode -np y ./elk
! \end{verbatim}
! The number of MPI processes is reported in the file {\tt INFO.OUT} which
! serves as a check that MPI is running correctly. Note that version 2 of the
! MPI libraries is required to run Elk.
! \item
! Phonon calculations use a simple form of parallelism by just examining the
! run directory for dynamical matrix files. These files are of the form
! \begin{verbatim}
! DYN_Qqqqq_qqqq_qqqq_Sss_Aaa_Pp.OUT
! \end{verbatim}
! and contain a single row of a particular dynamical matrix. Elk simply finds
! which {\tt DYN} files do not exist, chooses one and runs it. This way many
! independent runs of Elk can be started in the same directory on a networked
! file system (NFS), and will run until all the dynamical matrices files are
! completed. Should a particular run crash, then delete the associated empty
! {\tt DYN} file and rerun Elk.
! \end{enumerate}
!
! \subsection{Memory requirements}
! Elk is a memory-bound code and runs best on processors with large caches and
! a large number of memory channels per core. Some tasks in Elk require a
! considerable amount of memory which can exceed the physical memory of the
! computer. In such cases, the number of threads at the first nesting level
! can be reduced with (for example)
! \begin{verbatim}
! maxthd1
! -4
! \end{verbatim}
! which restricts the number of threads at the first nesting level to
! maxthd/4. Deeper nesting levels, which generally require less memory, will
! still utilise the full compliment of available threads.
! \subsubsection{Stack space}
! The latest versions of Elk use stack space aggressively. This is because
! accessing variables is faster on the stack than on the heap. This can,
! however, result in the code crashing as threads run out of their stack
! space. To avoid this, increase the stack size for each OpenMP thread with
! (for example)
! \begin{verbatim}
! export OMP_STACKSIZE=64M
! \end{verbatim}
! before running the code.
!
! \subsection{Linking with the Libxc functional library}
! Libxc is the ETSF library of exchange-correlation functionals. Elk can use
! the complete set of LDA and GGA functionals available in Libxc as well as
! the potential-only metaGGA's. In order to enable this, first download and
! compile Libxc version 5. This should have produced the files {\tt libxc.a}
! and {\tt libxcf90.a}. Copy these files to the {\tt elk/src} directory and
! then uncomment the lines indicated for Libxc in the file {\tt elk/make.inc}.
! Once this is done, run {\tt make clean} followed by {\tt make}. To select a
! particular functional of Libxc, use the block
! \begin{verbatim}
! xctype
! 100 nx nc
! \end{verbatim}
! where {\tt nx} and {\tt nc} are, respectively, the numbers of the exchange
! and correlation functionals in the Libxc library. See the file
! {\tt elk/src/libxcf90.f90} for a list of the functionals and their
! associated numbers.
!
! \subsection{Running the code}
! As a rule, all input files for the code are in lower case and end with the
! extension {\tt .in}. All output files are uppercase and have the extension
! {\tt .OUT}. For most cases, the user will only need to modify the file
! {\tt elk.in}. In this file input parameters are arranged in blocks.
! Each block consists of a block name on one line and the block variables on
! subsequent lines. Almost all blocks are optional: the code uses reasonable
! default values in cases where they are absent. Blocks can appear in any
! order, if a block is repeated then the second instance is used. Comment
! lines can be included in the input file and begin with the {\tt !}
! character.
!
! \subsubsection{Species files}
! The only other input files are those describing the atomic species which go
! into the crystal. These files are found in the {\tt species} directory and
! are named with the element symbol and the extension {\tt .in}, for example
! {\tt Sb.in}. They contain parameters like the atomic charge, mass,
! muffin-tin radius, occupied atomic states and the type of linearisation
! required. Here as an example is the copper species file {\tt Cu.in}:
! \begin{verbatim}
! 'Cu' : spsymb
! 'copper' : spname
! -29.0000 : spzn
! 115837.2716 : spmass
! 0.371391E-06 2.0000 34.8965 500 : rminsp, rmt, rmaxsp, nrmt
! 10 : nstsp
! 1 0 1 2.00000 T : nsp, lsp, ksp, occsp, spcore
! 2 0 1 2.00000 T
! 2 1 1 2.00000 T
! 2 1 2 4.00000 T
! 3 0 1 2.00000 T
! 3 1 1 2.00000 F
! 3 1 2 4.00000 F
! 3 2 2 4.00000 F
! 3 2 3 6.00000 F
! 4 0 1 1.00000 F
! 1 : apword
! 0.1500 0 F : apwe0, apwdm, apwve
! 1 : nlx
! 2 2 : lx, apword
! 0.1500 0 T : apwe0, apwdm, apwve
! 0.1500 1 T
! 4 : nlorb
! 0 2 : lorbl, lorbord
! 0.1500 0 F : lorbe0, lorbdm, lorbve
! 0.1500 1 F
! 1 2
! 0.1500 0 F
! 0.1500 1 F
! 2 2
! 0.1500 0 F
! 0.1500 1 F
! 1 3
! 0.1500 0 F
! 0.1500 1 F
! -2.8652 0 T
! \end{verbatim}
! The input parameters are defined as follows:
! \vskip 6pt
! {\tt spsymb} \\
! The symbol of the element.
! \vskip 6pt
! {\tt spname} \\
! The name of the element.
! \vskip 6pt
! {\tt spzn} \\
! Nuclear charge: should be negative since the electron charge is taken to be
! postive in the code; it can also be fractional for purposes of doping.
! \vskip 6pt
! {\tt spmass} \\
! Nuclear mass in atomic units.
! \vskip 6pt
! {\tt rminsp}, {\tt rmt}, {\tt rmaxsp}, {\tt nrmt} \\
! Respectively, the minimum radius on logarithmic radial mesh; muffin-tin
! radius; effective infinity for atomic radial mesh; and number of radial mesh
! points to muffin-tin radius.
! \vskip 6pt
! {\tt nstsp} \\
! Number of atomic states.
! \vskip 6pt
! {\tt nsp}, {\tt lsp}, {\tt ksp}, {\tt occsp}, {\tt spcore} \\
! Respectively, the principal quantum number of the radial Dirac equation;
! quantum number $l$; quantum number $k$ ($l$ or $l+1$); occupancy of atomic
! state (can be fractional); {\tt .T.} if state is in the core and therefore
! treated with the Dirac equation in the spherical part of the muffin-tin
! Kohn-Sham potential.
! \vskip 6pt
! {\tt apword} \\
! Default APW function order, i.e. the number of radial functions and
! therefore the order of the radial derivative matching at the muffin-tin
! surface.
! \vskip 6pt
! {\tt apwe0}, {\tt apwdm}, {\tt apwve} \\
! Respectively, the default APW linearisation energy; the order of the energy
! derivative of the APW radial function $\partial^m u(r)/\partial E^m$; and
! {\tt .T.} if the linearisation energy is allowed to vary.
! \vskip 6pt
! {\tt nlx} \\
! The number of exceptions to the default APW configuration. These should be
! listed on subsequent lines for particular angular momenta. In this example,
! the fixed energy APW with angular momentum $d$ ({\tt lx} $=2$) is replaced
! with a LAPW, which has variable linearisation energy.
! \vskip 6pt
! {\tt nlorb} \\
! Number of local-orbitals.
! \vskip 6pt
! {\tt lorbl}, {\tt lorbord} \\
! Respectively, the angular momentum $l$ of the local-orbital; and the order
! of the radial derivative which goes to zero at the muffin-tin surface.
! \vskip 6pt
! {\tt lorbe0}, {\tt lorbdm}, {\tt lorbve} \\
! Respectively, the default local-orbital linearisation energy; the order of
! the energy derivative of the local-orbital radial function; and {\tt .T.} if
! the linearisation energy is allowed to vary.
!
! \subsubsection{Examples}
! The best way to learn to use Elk is to run the examples included with the
! package. These can be found in the {\tt examples} directory and use many of
! the code's capabilities. The following section which describes all the input
! parameters will be of invaluable assistance.
!
! \section{Input blocks}
! This section lists all the input blocks available. It is arranged with the
! name of the block followed by a table which lists each parameter name, what
! the parameter does, its type and default value. A horizontal line in the
! table indicates a new line in {\tt elk.in}. Below the table is a brief
! overview of the block's function.
!
! \block{atoms}{
! {\tt nspecies} & number of species & integer & 0 \\
! \hline
! {\tt spfname(i)} & species filename for species $i$ & string & - \\
! \hline
! {\tt natoms(i)} & number of atoms for species $i$ & integer & - \\
! \hline
! {\tt atposl(j,i)} & atomic position in lattice coordinates for atom $j$
! & real(3) & - \\
! {\tt bfcmt(j,i)} & muffin-tin external magnetic field in Cartesian
! coordinates for atom $j$ & real(3) & -}
! Defines the atomic species as well as their positions in the unit cell and
! the external magnetic field applied throughout the muffin-tin. These fields
! are used to break spin symmetry and should be considered infinitesimal as
! they do not contribute directly to the total energy. Collinear calculations
! are more efficient if the field is applied in the $z$-direction. One could,
! for example, set up an antiferromagnetic crystal by pointing the field on
! one atom in the positive $z$-direction and in the opposite direction on
! another atom. If {\tt molecule} is {\tt .true.} then the atomic positions
! are assumed to be in Cartesian coordinates. See also {\tt sppath},
! {\tt bfieldc} and {\tt molecule}.
!
! \block{autokpt}{
! {\tt autokpt} & {\tt .true.} if the $k$-point set is to be determined
! automatically & logical & {\tt .false.}}
! See {\tt radkpt} for details.
!
! \block{autolinengy}{
! {\tt autolinengy} & {\tt .true.} if the fixed linearisation energies are
! to be determined automatically & logical & {\tt .false.}}
! See {\tt dlefe} for details.
!
! \block{autoswidth}{
! {\tt autoswidth} & {\tt .true.} if the smearing parameter {\tt swidth}
! should be determined automatically & logical & {\tt .false.}}
! Calculates the smearing width from the $k$-point density, $V_{\rm BZ}/n_k$;
! the valence band width, $W$; and an effective mass parameter, $m^{*}$;
! according to
! $$ \sigma=\frac{\sqrt{2W}}{m^{*}}\left(\frac{3}{4\pi}
! \frac{V_{\rm BZ}}{n_k}\right)^{1/3}. $$
! The variable {\tt mstar} then replaces {\tt swidth} as the control parameter
! of the smearing width. A large value of $m^{*}$ gives a narrower smearing
! function. Since {\tt swidth} is adjusted according to the fineness of the
! ${\bf k}$-mesh, the smearing parameter can then be eliminated. It is not
! recommended that {\tt autoswidth} be used in conjunction with the
! Fermi-Dirac smearing function, since the electronic temperature will then be
! a function of the $k$-point mesh. See T. Bj\"orkman and O. Gr\aa n\"as,
! {\it Int. J. Quant. Chem.} DOI: 10.1002/qua.22476 (2010) for details. See
! also {\tt stype} and {\tt swidth}.
!
! \block{avec}{
! {\tt avec(1)} & first lattice vector & real(3) & $(1.0,0.0,0.0)$ \\
! \hline
! {\tt avec(2)} & second lattice vector & real(3) & $(0.0,1.0,0.0)$ \\
! \hline
! {\tt avec(3)} & third lattice vector & real(3) & $(0.0,0.0,1.0)$}
! Lattice vectors of the crystal in atomic units (Bohr).
!
! \block{beta0}{
! {\tt beta0} & adaptive mixing parameter & real & $0.05$}
! This determines how much of the potential from the previous self-consistent
! loop is mixed with the potential from the current loop. It should be made
! smaller if the calculation is unstable. See {\tt betamax} and also the
! routine {\tt mixadapt}.
!
! \block{betamax}{
! {\tt betamax} & maximum adaptive mixing parameter & real & $0.5$}
! Maximum allowed mixing parameter used in routine {\tt mixadapt}.
!
! \block{bfieldc}{
! {\tt bfieldc} & global external magnetic field in Cartesian coordinates &
! real(3) & $(0.0,0.0,0.0)$}
! This is a constant magnetic field applied throughout the entire unit cell
! and enters the second-variational Hamiltonian as
! $$ \frac{g_e}{4c}\,\vec{\sigma}\cdot{\bf B}_{\rm ext}, $$
! where $g_e$ is the electron $g$-factor. This field is normally used to break
! spin symmetry for spin-polarised calculations and considered to be
! infinitesimal with no direct contribution to the total energy. In cases
! where the magnetic field is finite (for example when computing magnetic
! response) the external ${\bf B}$-field energy reported in {\tt INFO.OUT}
! should be added to the total by hand. This field is applied throughout the
! entire unit cell. To apply magnetic fields in particular muffin-tins use the
! {\tt bfcmt} vectors in the {\tt atoms} block. Collinear calculations are
! more efficient if the field is applied in the $z$-direction.
!
! \block{broydpm}{
! {\tt broydpm} & Broyden mixing parameters $\alpha$ and $w_0$ & real &
! $(0.4,0.15)$}
! See {\tt mixtype} and {\tt mixsdb}.
!
! \block{c\_tb09}{
! {\tt c\_tb09} & Tran-Blaha constant $c$ & real & -}
! Sets the constant $c$ in the Tran-Blaha '09 functional. Normally this is
! calculated from the density, but there may be situations where this needs to
! be adjusted by hand. See {\it Phys. Rev. Lett.} {\bf 102}, 226401 (2009).
!
! \block{chgexs}{
! {\tt chgexs} & excess electronic charge & real & $0.0$}
! This controls the amount of charge in the unit cell beyond that required to
! maintain neutrality. It can be set positive or negative depending on whether
! electron or hole doping is required.
!
! \block{cmagz}{
! {\tt cmagz} & .true. if $z$-axis collinear magnetism is to be enforced &
! logical & {\tt .false.}}
! This variable can be set to .true. in cases where the magnetism is
! predominantly collinear in the $z$-direction, for example a ferromagnet with
! spin-orbit coupling. This will make the calculation considerably faster at
! the slight expense of precision.
!
! \block{deltaem}{
! {\tt deltaem} & the size of the ${\bf k}$-vector displacement used when
! calculating numerical derivatives for the effective mass tensor & real &
! $0.025$}
! See {\tt ndspem} and {\tt vklem}.
!
! \block{deltaph}{
! {\tt deltaph} & size of the atomic displacement used for calculating
! dynamical matrices & real & $0.01$}
! Phonon calculations are performed by constructing a supercell corresponding
! to a particular ${\bf q}$-vector and making a small periodic displacement of
! the atoms. The magnitude of this displacement is given by {\tt deltaph}.
! This should not be made too large, as anharmonic terms could then become
! significant, neither should it be too small as this can introduce numerical
! error.
!
! \block{deltast}{
! {\tt deltast} & size of the change in lattice vectors used for calculating
! the stress tensor & real & $0.005$}
! The stress tensor is computed by changing the lattice vector matrix $A$ by
! $$ A\rightarrow (1+\delta t\,e_i)A, $$
! where $dt$ is an infinitesimal equal in practice to {\tt deltast} and $e_i$
! is the $i^{\rm th}$ strain tensor. Numerical finite differences are used to
! compute the stress tensor as the derivative of the total energy $dE_i/dt$.
!
! \block{dft+u}{
! {\tt dftu} & type of DFT+$U$ calculation & integer & 0 \\
! {\tt inpdftu} & type of input for DFT+U calculation & integer & 1 \\
! \hline
! {\tt is} & species number & integer & - \\
! {\tt l} & angular momentum value & integer & -1 \\
! {\tt u} & the desired $U$ value & real & $0.0$ \\
! {\tt j} & the desired $J$ value & real & $0.0$}
! This block contains the parameters required for an DFT+$U$ calculation, with
! the list of parameters for each species terminated with a blank line. The
! type of double counting required is set with the parameter {\tt dftu}.
! Currently implemented are:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! 0 & No DFT+$U$ calculation \\
! 1 & Fully localised limit (FLL) \\
! 2 & Around mean field (AFM) \\
! 3 & An interpolation between FLL and AFM \\
! \end{tabularx}
! \vskip 6pt
! The type of input parameters is set with the parameter {\tt inpdftu}.
! The current possibilities are:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! 1 & U and J \\
! 2 & Slater parameters \\
! 3 & Racah parameters \\
! 4 & Yukawa screening length \\
! 5 & U and determination of corresponding Yukawa screening length
! \end{tabularx}
! \vskip 6pt
! See (amongst others) {\it Phys. Rev. B} {\bf 67}, 153106 (2003),
! {\it Phys. Rev. B} {\bf 52}, R5467 (1995), {\it Phys. Rev. B} {\bf 60},
! 10763 (1999), and {\it Phys. Rev. B} {\bf 80}, 035121 (2009).
!
! \block{dlefe}{
! {\tt dlefe} & difference between the fixed linearisation energy and the
! Fermi energy & real & $-0.1$}
! When {\tt autolinengy} is {\tt .true.} then the fixed linearisation energies
! are set to the Fermi energy plus {\tt dlefe}.
!
! \block{dncgga}{
! {\tt dncgga} & small constant used to stabilise non-collinear GGA &
! real & $1\times 10^{-8}$}
! This small constant, $d$, is required in order to remove the infinite
! gradients obtained when using `Kubler's trick' in conjunction with GGA and
! non-collinear magnetism. It is applied by calculating the up and down
! densities as
! $$ \rho^{\uparrow}({\bf r})=\rho({\bf r})+\widetilde{m}({\bf r})
! \qquad \rho^{\downarrow}({\bf r})=\rho({\bf r})-\widetilde{m}({\bf r}), $$
! where $\widetilde{m}({\bf r})=\sqrt{{\bf m}^2({\bf r})+d}$,
! and should be taken as the smallest value for which the exchange-correlation
! magnetic field ${\bf B}_{\rm xc}$ is smooth.
!
! \block{dosmsum}{
! {\tt dosmsum} & {\tt .true.} if the partial DOS is to be summed over $m$ &
! logical & {\tt .false.}}
! By default, the partial density of states is resolved over $(l,m)$ quantum
! numbers. If {\tt dosmsum} is set to {\tt .true.} then the partial DOS is
! summed over $m$, and thus depends only on $l$.
!
! \block{dosssum}{
! {\tt dosssum} & {\tt .true.} if the partial DOS is to be summed over spin &
! logical & {\tt .false.}}
! By default, the partial density of states for spin-polarised systems is spin
! resolved.
!
! \block{dtimes}{
! {\tt dtimes} & time step used in time evolution run & real & $0.1$}
! See also {\tt tstime}.
!
! \block{epsband}{
! {\tt epsband} & convergence tolerance for determining band energies & real &
! $1\times 10^{-12}$}
! APW and local-orbital linearisation energies are determined from the band
! energies. This is done by first searching upwards in energy until the radial
! wavefunction at the muffin-tin radius is zero. This is the energy at the top
! of the band, denoted $E_{\rm t}$. A downward search is now performed from
! $E_{\rm t}$ until the slope of the radial wavefunction at the muffin-tin
! radius is zero. This energy, $E_{\rm b}$, is at the bottom of the band. The
! band energy is taken as $(E_{\rm t}+E_{\rm b})/2$. If either $E_{\rm t}$ or
! $E_{\rm b}$ is not found, then the band energy is set to the default value.
!
! \block{epschg}{
! {\tt epschg} & maximum allowed error in the calculated total charge beyond
! which a warning message will be issued & real & $1\times 10^{-3}$}
!
! \block{epsengy}{
! {\tt epsengy} & convergence criterion for the total energy & real &
! $1\times 10^{-4}$}
! See {\tt epspot}.
!
! \block{epsforce}{
! {\tt epsforce} & convergence tolerance for the forces during a geometry
! optimisation run & real & $2\times 10^{-3}$}
! If the mean absolute value of the atomic forces is less than {\tt epsforce}
! then the geometry optimisation run is ended. See also {\tt tasks} and
! {\tt latvopt}.
!
! \block{epslat}{
! {\tt epslat } & vectors with lengths less than this are considered zero &
! real & $10^{-6}$}
! Sets the tolerance for determining if a vector or its components are zero.
! This is to account for any numerical error in real or reciprocal space
! vectors.
!
! \block{epsocc}{
! {\tt epsocc} & smallest occupancy for which a state will contribute to the
! density & real & $1\times 10^{-8}$}
!
! \block{epspot}{
! {\tt epspot} & convergence criterion for the Kohn-Sham potential and field &
! real & $1\times 10^{-6}$}
! If the RMS change in the Kohn-Sham potential and magnetic field is smaller
! than {\tt epspot} and the absolute change in the total energy is less than
! {\tt epsengy}, then the self-consistent loop is considered converged
! and exited. For geometry optimisation runs this results in the forces being
! calculated, the atomic positions updated and the loop restarted. See also
! {\tt epsengy} and {\tt maxscl}.
!
! \block{epsstress}{
! {\tt epsstress} & convergence tolerance for the stress tensor during a
! geometry optimisation run with lattice vector relaxation & real &
! $5\times 10^{-4}$}
! See also {\tt epsforce} and {\tt latvopt}.
!
! \block{emaxelnes}{
! {\tt emaxelnes} & maximum allowed initial-state eigenvalue for ELNES
! calculations & real & $-1.2$}
!
! \block{emaxrf}{
! {\tt emaxrf} & energy cut-off used when calculating Kohn-Sham response
! functions & real & $10^6$}
! A typical Kohn-Sham response function is of the form
! \begin{align*}
! \chi_s({\bf r},{\bf r}',\omega)
! \equiv\frac{\delta\rho({\bf r},\omega)}{\delta v_s({\bf r}',\omega)}
! =\frac{1}{N_k}\sum_{i{\bf k},j{\bf k}'}(f_{i{\bf k}}-f_{j{\bf k}'})
! \frac{\langle i{\bf k}|\hat{\rho}({\bf r})|j{\bf k}'\rangle
! \langle j{\bf k}'|\hat{\rho}({\bf r}')|i{\bf k}\rangle}
! {w+(\varepsilon_{i{\bf k}}-\varepsilon_{j{\bf k}'})+i\eta},
! \end{align*}
! where $\hat{\rho}$ is the density operator; $N_k$ is the number of
! $k$-points; $\varepsilon_{i{\bf k}}$ and $f_{i{\bf k}}$ are the eigenvalues
! and occupation numbers, respectively. The variable {\tt emaxrf} is an energy
! window which limits the summation over states in the formula above so that
! $|\varepsilon_{i{\bf k}}-\varepsilon_{\rm Fermi}|<{\tt emaxrf}$. Reducing
! this can result in a faster calculation at the expense of accuracy.
!
! \block{fracinr}{
! {\tt fracinr} & fraction of the muffin-tin radius up to which {\tt lmaxi}
! is used as the angular momentum cut-off & real & $0.01$}
! If {\tt fracinr} is negative then the fraction is determined from
! $f=\sqrt{({\tt lmaxi}+1)^2/({\tt lmaxo}+1)^2}$ in order to
! maintain a minimum density of points throughout the muffin-tin. See
! {\tt lmaxi} and {\tt lmaxo}.
!
! \block{fsmtype}{
! {\tt fsmtype} & 0 for no fixed spin moment (FSM), 1 for total FSM, 2 for
! local muffin-tin FSM, and 3 for both total and local FSM & integer & 0}
! Set to 1, 2 or 3 for fixed spin moment calculations. To fix only the
! direction and not the magnitude set to $-1$, $-2$ or $-3$. See also
! {\tt momfix}, {\tt mommtfix}, {\tt taufsm} and {\tt spinpol}.
!
! \block{ftmtype}{
! {\tt ftmtype} & 1 to enable a fixed tensor moment (FTM) calculation,
! 0 otherwise & integer & 0}
! If {\tt ftmtype} is $-1$ then the symmetry corresponding to the tensor
! moment is broken but no FTM calculation is performed. See {\it Phys. Rev.
! Lett.} {\bf 103}, 107202 (2009) and also {\tt tmomfix}.
!
! \block{fxclrc}{
! {\tt fxclrc} & parameters for the dynamical long-range contribution (LRC) to
! the TDDFT exchange-correlation kernel & real(2) & $(0.0,0.0)$}
! These are the parameters $\alpha$ and $\beta$ for the kernel proposed in
! {\it Phys. Rev. B} {\bf 72}, 125203 (2005), namely
! $$ f_{xc}({\bf G},{\bf G}',{\bf q},\omega)=-\frac{\alpha+\beta\omega^2}{q^2}
! \delta_{{\bf G},{\bf G}'}\delta_{{\bf G},{\bf 0}}. $$
!
! \block{fxctype}{
! {\tt fxctype} & integer defining the type of exchange-correlation kernel
! $f_{\rm xc}$ & integer & $-1$}
! The acceptable values are:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! $-1$ & $f_{\rm xc}$ defined by {\tt xctype} \\
! 0,1 & RPA ($f_{\rm xc}=0$) \\
! 200 & Long-range contribution (LRC) kernel, S. Botti {\it et al.},
! {\it Phys. Rev. B} {\bf 72}, 125203 (2005); see {\tt fxclrc} \\
! 210 & `Bootstrap' kernel, S. Sharma, J. K. Dewhurst, A. Sanna and
! E. K. U. Gross, {\it Phys. Rev. Lett.} {\bf 107}, 186401 (2011) \\
! 211 & Single iteration bootstrap
! \end{tabularx}
!
! \block{gmaxrf}{
! {\tt gmaxrf} & maximum length of $|{\bf G}|$ for computing response
! functions & real & $3.0$}
!
! \block{gmaxvr}{
! {\tt gmaxvr} & maximum length of $|{\bf G}|$ for expanding the interstitial
! density and potential & real & $12.0$}
! This variable has a lower bound which is enforced by the code as follows:
! $$ {\rm gmaxvr}\rightarrow\max\,({\rm gmaxvr},2\times{\rm gkmax}
! +{\rm epslat}) $$
! See {\tt rgkmax}.
!
! \block{hdbse}{
! {\tt hdbse} & {\tt .true.} if the direct term is to be included in the BSE
! Hamiltonian & logical & {\tt .true.}}
!
! \block{highq}{
! {\tt highq} & {\tt .true.} if a high quality parameter set should be used &
! logical & {\tt .false.}}
! Setting this to {\tt .true.} results in some default parameters being
! changed to ensure good convergence in most situations. These changes can be
! overruled by subsequent blocks in the input file. See also {\tt vhighq}.
!
! \block{hmaxvr}{
! {\tt hmaxvr} & maximum length of ${\bf H}$-vectors & real & $6.0$}
! The ${\bf H}$-vectors are used for calculating X-ray and magnetic structure
! factors. They are also used in linear response phonon calculations for
! expanding the density and potential in plane waves. See also {\tt gmaxvr},
! {\tt vhmat}, {\tt reduceh}, {\tt wsfac} and {\tt hkmax}.
!
! \block{hxbse}{
! {\tt hxbse} & {\tt .true.} if the exchange term is to be included in the BSE
! Hamiltonian & {\tt .true.}}
!
! \block{hybrid}{
! {\tt hybrid} & {\tt .true} if a hybrid functional is to be used when running
! a Hartree-Fock calculation & logical & {\tt .false}}
! See also {\tt hybridc} and {\tt xctype}.
!
! \block{hybridc}{
! {\tt hybridc} & hybrid functional mixing coefficient & real & $1.0$}
!
! \block{intraband}{
! {\tt intraband} & {\tt .true.} if the intraband (Drude-like) contribution is
! to be added to the dieletric tensor & logical & {\tt .false.}}
!
! \block{isgkmax}{
! {\tt isgkmax} & species for which the muffin-tin radius will be used for
! calculating {\tt gkmax} & integer & $-1$}
! The APW cut-off is determined from ${\tt gkmax}={\tt rgkmax}/R$. The
! variable {\tt isgkmax} determines which muffin-tin radius is to be used for
! $R$. These are the options:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! -4 & Use the largest radius \\
! -3 & Use the smallest radius \\
! -2 & Use the fixed value $R=2.0$ \\
! -1 & Use the average of the muffin-tin radii \\
! $n\ge 1$ & Use the radius of species $n$
! \end{tabularx}
!
! \block{kstlist}{
! {\tt kstlist(i)} & $i$th $k$-point and state pair & integer(2) & $(1,1)$}
! This is a user-defined list of $k$-point and state index pairs which are
! those used for plotting wavefunctions and writing ${\bf L}$, ${\bf S}$ and
! ${\bf J}$ expectation values. Only the first pair is used by the
! aforementioned tasks. The list should be terminated by a blank line.
!
! \block{latvopt}{
! {\tt latvopt} & type of lattice vector optimisation to be performed during
! structural relaxation & integer & 0}
! Optimisation of the lattice vectors will be performed with ${\tt task}=2,3$
! when ${\tt latvopt}\ne 0$. When ${\tt latvopt}=1$ the lattice vector
! optimisation will be constrained only by symmetry. Optimisation over all
! symmetry-preserving strains except isotropic scaling is performed when
! ${\tt latvopt}=2$. If ${\tt latvopt}<0$ then the optimisation will be over
! strain number $|{\tt latvopt}|$. The list of symmetric strain tensors can be
! produced with ${\tt task}=430$. By default (${\tt latvopt}=0$) no lattice
! vector optimisation is performed during structural relaxation. See also
! {\tt tau0latv} and {\tt atpopt}.
!
! \block{lmaxapw}{
! {\tt lmaxapw} & angular momentum cut-off for the APW functions & integer &
! $8$}
!
! \block{lmaxdos}{
! {\tt lmaxdos} & angular momentum cut-off for the partial DOS plot &
! integer & $3$}
!
! \block{lmaxi}{
! {\tt lmaxi} & angular momentum cut-off for the muffin-tin density and
! potential on the inner part of the muffin-tin & integer & 2}
! Close to the nucleus, the density and potential is almost spherical and
! therefore the spherical harmonic expansion can be truncated a low angular
! momentum. See also {\tt fracinr}.
!
! \block{lmaxo}{
! {\tt lmaxo} & angular momentum cut-off for the muffin-tin density and
! potential & integer & 6}
!
! \block{lmirep}{
! {\tt lmirep} & {\tt .true.} if the $Y_{lm}$ basis is to be transformed
! into the basis of irreducible representations of the site symmetries for
! DOS plotting & logical & {\tt .true.}}
! When lmirep is set to .true., the spherical harmonic basis is transformed
! into one in which the site symmetries are block diagonal. Band characters
! determined from the density matrix expressed in this basis correspond to
! irreducible representations, and allow the partial DOS to be resolved into
! physically relevant contributions, for example $e_g$ and $t_{2g}$.
!
! \block{lorbcnd}{
! {\tt lorbcnd} & {\tt .true.} if conduction state local-orbitals are to be
! automatically added to the basis & logical & {\tt .false.}}
! Adding these higher energy local-orbitals can improve calculations which
! rely on accurate unoccupied states, such as the response function. See also
! {\tt lorbordc}.
!
! \block{lorbordc}{
! {\tt lorbordc} & the order of the conduction state local-orbitals &
! integer & 2}
! See {\tt lorbcnd}.
!
! \block{lradstp}{
! {\tt lradstp} & radial step length for determining coarse radial mesh &
! integer & 4}
! Some muffin-tin functions (such as the density) are calculated on a coarse
! radial mesh and then interpolated onto a fine mesh. This is done for the
! sake of efficiency. {\tt lradstp} defines the step size in going from the
! fine to the coarse radial mesh. If it is too large, loss of precision may
! occur.
!
! \block{maxitoep}{
! {\tt maxitoep} & maximum number of iterations when solving the exact
! exchange integral equations & integer & 300}
! See {\tt tau0oep}.
!
! \block{maxscl}{
! {\tt maxscl } & maximum number of self-consistent loops allowed & integer &
! 200}
! This determines after how many loops the self-consistent cycle will
! terminate if the convergence criterion is not met. If {\tt maxscl} is $1$
! then the density and potential file, {\tt STATE.OUT}, will {\bf not} be
! written to disk at the end of the loop. See {\tt epspot}.
!
! \block{mixtype}{
! {\tt mixtype } & type of mixing required for the potential & integer & 1}
! Currently implemented are:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! 0 & Linear mixing \\
! 1 & Adaptive linear mixing \\
! 3 & Broyden mixing, {\it J. Phys. A: Math. Gen.} {\bf 17}, L317 (1984)
! \end{tabularx}
!
! \block{mixsdb}{
! {\tt mixsdb} & subspace dimension for Broyden mixing & integer & 5}
! This is the number of mixing vectors which define the subspace in which the
! Hessian matrix is calculated. See {\tt mixtype} and {\tt broydpm}.
!
! \block{molecule}{
! {\tt molecule} & {\tt .true.} if the system is an isolated molecule &
! logical & {\tt .false.}}
! If {\tt molecule} is {\tt .true.}, then the atomic positions, ${\bf a}$,
! given in the {\tt atoms} block are assumed to be in Cartesian coordinates.
!
! \block{momfix}{
! {\tt momfix} & the desired total moment for a FSM calculation &
! real(3) & $(0.0,0.0,0.0)$}
! Note that all three components must be specified (even for collinear
! calculations). See {\tt fsmtype}, {\tt taufsm} and {\tt spinpol}.
!
! \block{mommtfix}{
! {\tt is} & species number & integer & 0 \\
! {\tt ia} & atom number & integer & 0 \\
! {\tt mommtfix} & the desired muffin-tin moment for a FSM calculation &
! real(3) & $(0.0,0.0,0.0)$}
! The local muffin-tin moments are specified for a subset of atoms, with the
! list terminated with a blank line. Note that all three components must be
! specified (even for collinear calculations). See {\tt fsmtype}, {\tt taufsm}
! and {\tt spinpol}.
!
! \block{msmooth}{
! {\tt msmooth} & amount of smoothing to be applied to the
! exchange-correlation potentials and magnetic field & integer & 0}
! Smoothing operations can be applied to the exchange-correlation potentials
! $v_{xc}$, $w_{xc}$ and the magnetic field ${\bf B}_{xc}$ in order to improve
! convergence. In the muffin-tin, this smoothing takes the form of $m$
! successive three-point running averages applied to the radial component. In
! the interstitial region, the potential is first Fourier transformed to
! $G$-space, then a low-pass filter of the form $\exp[-2m(G/G_{\rm max})^8]$
! is applied and the function is transformed back to real-space.
!
! \block{mstar}{
! {\tt mstar} & value of the effective mass parameter used for adaptive
! determination of {\tt swidth} & real & $10.0$}
! See {\tt autoswidth}.
!
! \block{mustar}{
! {\tt mustar} & Coulomb pseudopotential, $\mu^*$, used in the
! McMillan-Allen-Dynes equation & real & $0.15$}
! This is used when calculating the superconducting critical temperature with
! the formula {\it Phys. Rev. B 12, 905 (1975)}
! $$ T_c=\frac{\omega_{\rm log}}{1.2 k_B}\exp\left[\frac{-1.04(1+\lambda)}
! {\lambda-\mu^*(1+0.62\lambda)}\right], $$
! where $\omega_{\rm log}$ is the logarithmic average frequency and $\lambda$
! is the electron-phonon coupling constant.
!
! \block{ncbse}{
! {\tt ncbse} & number of conduction states to be used for BSE calculations &
! integer & 3}
! See also {\tt nvbse}.
!
! \block{ndspem}{
! {\tt ndspem} & the number of {\bf k}-vector displacements in each direction
! around {\tt vklem} when computing the numerical derivatives for the
! effective mass tensor & integer & 1}
! See {\tt deltaem} and {\tt vklem}.
!
! \block{nempty}{
! {\tt nempty} & the number of empty states per atom and spin & real & $4.0$ }
! Defines the number of eigenstates beyond that required for charge
! neutrality. When running metals it is not known {\it a priori} how many
! states will be below the Fermi energy for each $k$-point. Setting
! {\tt nempty} greater than zero allows the additional states to act as a
! buffer in such cases. Furthermore, magnetic calculations use the
! first-variational eigenstates as a basis for setting up the
! second-variational Hamiltonian, and thus {\tt nempty} will determine the
! size of this basis set. Convergence with respect to this quantity should be
! checked.
!
! \block{ngridk}{
! {\tt ngridk } & the $k$-point mesh sizes & integer(3) & $(1,1,1)$}
! The ${\bf k}$-vectors are generated using
! $$ {\bf k}=(\frac{i_1+v_1}{n_1},\frac{i_2+v_2}{n_2},\frac{i_3+v_3}{n_3}), $$
! where $i_j$ runs from 0 to $n_j-1$ and $0\le v_j<1$ for $j=1,2,3$. The
! vector ${\bf v}$ is given by the variable {\tt vkloff}. See also
! {\tt reducek}.
!
! \block{ngridq}{
! {\tt ngridq } & the phonon $q$-point mesh sizes & integer(3) & $(1,1,1)$}
! Same as {\tt ngridk}, except that this mesh is for the phonon $q$-points
! and other tasks. See also {\tt reduceq}.
!
! \block{nosource}{
! {\tt nosource} & when set to {\tt .true.}, source fields are projected out
! of the exchange-correlation magnetic field & logical & {\tt .false.}}
! Experimental feature.
!
! \block{notes}{
! {\tt notes(i)} & the $i$th line of the notes & string & -}
! This block allows users to add their own notes to the file {\tt INFO.OUT}.
! The block should be terminated with a blank line, and no line should exceed
! 80 characters.
!
! \block{npmae}{
! {\tt npmae } & number or distribution of directions for MAE calculations &
! integer & $-1$}
! Automatic determination of the magnetic anisotropy energy (MAE) requires
! that the total energy is determined for a set of directions of the total
! magnetic moment. This variable controls the number or distribution of these
! directions. The convention is:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! $-4,-3,-2,-1$ & Cardinal directions given by the primitive translation
! vectors $n_1{\bf A}_1+n_2{\bf A}_2+n_3{\bf A}_3$, where
! $1\le n_i\le|{\tt npmae}|$ \\
! 2 & Cartesian $x$ and $z$ directions \\
! 3 & Cartesian $x$, $y$ and $z$ directions \\
! $4,5,\ldots$ & Even distribution of {\tt npmae} directions
! \end{tabularx}
!
! \block{ntemp}{
! {\tt ntemp} & number of temperature steps & integer & 40}
! This is the number of temperature steps to be used in the Eliashberg gap
! and thermodynamic properties calculations.
!
! \block{nvbse}{
! {\tt nvbse} & number of valence states to be used for BSE calculations &
! integer & 2}
! See also {\tt ncbse}.
!
! \block{nwrite}{
! {\tt nwrite} & number of self-consistent loops after which {\tt STATE.OUT}
! is to be written & integer & 0}
! Normally, the density and potentials are written to the file {\tt STATE.OUT}
! only after completion of the self-consistent loop. By setting {\tt nwrite}
! to a positive integer the file will instead be written every {\tt nwrite}
! loops.
!
! \block{nxoapwlo}{
! {\tt nxoapwlo} & extra order of radial functions to be added to the existing
! APW and local-orbital set & integer & 0}
! Setting this variable will result in the APWs and local-orbitals for all
! species becoming higher order with corresponding increase in derivative
! matching at the muffin-tin surface. For example, setting {\tt nxoapwlo}=1
! turns all APWs into LAPWs.
!
! \block{optcomp}{
! {\tt optcomp} & the components of the first- or second-order optical tensor
! to be calculated & integer(3) & $(1,1,1)$}
! This selects which components of the optical tensor you would like to plot.
! Only the first two are used for the first-order tensor. Several components
! can be listed one after the other with a blank line terminating the list.
!
! \block{phwrite}{
! {\tt nphwrt} & number of $q$-points for which phonon modes are to be found &
! integer & 1 \\
! \hline
! {\tt vqlwrt(i)} & the $i$th $q$-point in lattice coordinates & real(3) &
! $(0.0,0.0,0.0)$}
! This is used in conjunction with {\tt task}=230. The code will write the
! phonon frequencies and eigenvectors to the file {\tt PHONON.OUT} for all the
! $q$-points in the list. The $q$-points can be anywhere in the Brillouin zone
! and do not have to lie on the mesh defined by {\tt ngridq}. Obviously, all
! the dynamical matrices have to be computed first using {\tt task}=200.
!
! \block{plot1d}{
! {\tt nvp1d} & number of vertices & integer & 2 \\
! {\tt npp1d} & number of plotting points & integer & 200 \\
! \hline
! {\tt vvlp1d(i)} & lattice coordinates for vertex $i$ & real(3) &
! $(0.0,0.0,0.0)\rightarrow(1.0,1.0,1.0)$}
! Defines the path in either real or reciprocal space along which the 1D plot
! is to be produced. The user should provide {\tt nvp1d} vertices in lattice
! coordinates.
!
! \block{plot2d}{
! {\tt vclp2d(0)} & zeroth corner (origin) & real(3) & $(0.0,0.0,0.0)$ \\
! \hline
! {\tt vclp2d(1)} & first corner & real(3) & $(1.0,0.0,0.0)$ \\
! \hline
! {\tt vclp2d(2)} & second corner & real(3) & $(0.0,1.0,0.0)$ \\
! \hline
! {\tt np2d} & number of plotting points in both directions & integer(2) &
! $(40,40)$}
! Defines the corners of a parallelogram and the grid size used for producing
! 2D plots.
!
! \block{plot3d}{
! {\tt vclp3d(0)} & zeroth corner (origin) & real(3) & $(0.0,0.0,0.0)$ \\
! \hline
! {\tt vclp3d(1)} & first corner & real(3) & $(1.0,0.0,0.0)$ \\
! \hline
! {\tt vclp3d(2)} & second corner & real(3) & $(0.0,1.0,0.0)$ \\
! \hline
! {\tt vclp3d(3)} & third corner & real(3) & $(0.0,0.0,1.0)$ \\
! \hline
! {\tt np3d} & number of plotting points each direction & integer(3) &
! $(20,20,20)$}
! Defines the corners of a box and the grid size used for producing 3D plots.
!
! \block{primcell}{
! {\tt primcell} & {\tt .true.} if the primitive unit cell should be found
! & logical & {\tt .false.}}
! Allows the primitive unit cell to be determined automatically from the
! conventional cell. This is done by searching for lattice vectors among all
! those which connect atomic sites, and using the three shortest which produce
! a unit cell with non-zero volume.
!
! \block{pulse}{
! {\tt n} & number of pulses & integer & - \\
! \hline
! {\tt a0(i)} & polarisation vector (including amplitude) & real(3) & - \\
! {\tt w(i)} & frequency & real & - \\
! {\tt phi(i)} & phase in degrees & real & - \\
! {\tt rc(i)} & chirp rate & real & - \\
! {\tt t0(i)} & peak time & real & - \\
! {\tt d(i)} & full-width at half-maximum & real & -}
! Parameters used to generate a time-dependent vector potential ${\bf A}(t)$
! representing a laser pulse. The total vector potential is the sum of
! individual pulses and is given by the formula
! $$ {\bf A}(t)=\sum_{i=1}^n {\bf A}_0^i\exp
! \left[-(t-t_0^i)^2/2\sigma_i^2\right]
! \sin\left[w_i(t-t_0^i)+\phi_i+r_{\rm c}^i t^2/2\right], $$
! where $\sigma=d/2\sqrt{2\ln 2}$. See also {\tt ramp}.
!
! \block{radkpt}{
! {\tt radkpt } & radius of sphere used to determine $k$-point density &
! real & $40.0$}
! Used for the automatic determination of the $k$-point mesh. If {\tt autokpt}
! is set to {\tt .true.} then the mesh sizes will be determined by
! $n_i=R_k|{\bf B}_i|+1$, where ${\bf B}_i$ are the primitive reciprocal
! lattice vectors.
!
! \block{ramp}{
! {\tt n} & number of ramps & integer & - \\
! \hline
! {\tt a0(i)} & polarisation vector (including amplitude) & real(3) & - \\
! {\tt t0(i)} & ramp start time & real & - \\
! {\tt c1(i)} & linear coefficient of ${\bf A}(t)$ & real & - \\
! {\tt c2(i)} & quadratic coefficient & real & -}
! Parameters used to generate a time-dependent vector potential ${\bf A}(t)$
! representing a constant or linearly increasing electric field
! ${\bf E}(t)=-\partial{\bf A}(t)/\partial t$. The vector potential is given
! by
! $$ {\bf A}(t)=\sum_{i=1}^n {\bf A}_0^i
! \left[c_1(t-t_0)+c_2(t-t_0)^2\right]\Theta(t-t_0). $$
!
! \block{readadu}{
! {\tt readadu} & set to {\tt .true.} if the interpolation constant for
! DFT+$U$ should be read from file rather than calculated & logical &
! {\tt .false.}}
! When {\tt dftu}=3, the DFT+$U$ energy and potential are interpolated
! between FLL and AFM. The interpolation constant, $\alpha$, is normally
! calculated from the density matrix, but can also be read in from the file
! {\tt ALPHADU.OUT}. This allows the user to fix $\alpha$, but is also
! necessary when calculating forces, since the contribution of the potential
! of the variation of $\alpha$ with respect to the density matrix is not
! computed. See {\tt dft+u}.
!
! \block{reducebf}{
! {\tt reducebf} & reduction factor for the external magnetic fields & real &
! $1.0$}
! After each self-consistent loop, the external magnetic fields are multiplied
! with {\tt reducebf}. This allows for a large external magnetic field at the
! start of the self-consistent loop to break spin symmetry, while at the end
! of the loop the field will be effectively zero, i.e. infinitesimal. See
! {\tt bfieldc} and {\tt atoms}.
!
! \block{reduceh}{
! {\tt reduceh} & set to {\tt .true.} if the reciprocal ${\bf H}$-vectors
! should be reduced by the symmorphic crystal symmetries & logical & .true.}
! See {\tt hmaxvr} and {\tt vmat}.
!
! \block{reducek}{
! {\tt reducek} & type of reduction of the $k$-point set & integer & 1}
! Types of reduction are defined by the symmetry group used:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! 0 & no reduction \\
! 1 & reduce with full crystal symmetry group (including non-symmorphic
! symmetries) \\
! 2 & reduce with symmorphic symmetries only
! \end{tabularx}
! \vskip 6pt
! See also {\tt ngridk} and {\tt vkloff}.
!
! \block{reduceq}{
! {\tt reduceq} & type of reduction of the $q$-point set & integer & 1}
! See {\tt reducek} and {\tt ngridq}.
!
! \block{rgkmax}{
! {\tt rgkmax} & $R^{\rm MT}_{\rm min}\times\max\{|{\bf G}+{\bf k}|\}$ &
! real & $7.0$}
! This sets the maximum length for the ${\bf G}+{\bf k}$ vectors, defined as
! {\tt rgkmax} divided by the average muffin-tin radius. See {\tt isgkmax}.
!
! \block{rotavec}{
! {\tt axang} & axis-angle representation of lattice vector rotation &
! real(4) & $(0.0,0.0,0.0,0.0)$}
! This determines the rotation matrix which is applied to the lattice vectors
! prior to any calculation. The first three components specify the axis and
! the last component is the angle in degrees. The `right-hand rule' convention
! is followed.
!
! \block{scale}{
! {\tt scale } & lattice vector scaling factor & real & $1.0$}
! Scaling factor for all three lattice vectors. Applied in conjunction with
! {\tt scale1}, {\tt scale2} and {\tt scale3}.
!
! \block{scale1/2/3}{
! {\tt scale1/2/3 } & separate scaling factors for each lattice vector &
! real & $1.0$}
!
! \block{scissor}{
! {\tt scissor} & the scissor correction & real & $0.0$}
! This is the scissor shift applied to states above the Fermi energy
! {\it Phys. Rev. B} {\bf 43}, 4187 (1991). Affects optics calculations only.
!
! \block{scrpath}{
! {\tt scrpath} & scratch space path & string & null}
! This is the scratch space path where the eigenvector files {\tt EVALFV.OUT}
! and {\tt EVALSV.OUT} will be written. If the run directory is accessed via a
! network then {\tt scrpath} can be set to a directory on the local disk, for
! example {\tt /tmp/}. Note that the forward slash {\tt /} at the end of the
! path must be included.
!
! \block{socscf}{
! {\tt socscf} & scaling factor for the spin-orbit coupling term in the
! Hamiltonian & real & $1.0$}
! This can be used to enhance the effect of spin-orbit coupling in order to
! accurately determine the magnetic anisotropy energy (MAE).
!
! \block{spincore}{
! {\tt spincore} & set to {\tt .true.} if the core should be spin-polarised
! & logical & {\tt .false.}}
!
! \block{spinorb}{
! {\tt spinorb} & set to {\tt .true.} if a spin-orbit coupling is required
! & logical & {\tt .false.}}
! If {\tt spinorb} is {\tt .true.}, then a $\boldsymbol\sigma\cdot{\bf L}$
! term is added to the second-variational Hamiltonian. See {\tt spinpol}.
!
! \block{spinpol}{
! {\tt spinpol} & set to {\tt .true.} if a spin-polarised calculation is
! required & logical & {\tt .false.}}
! If {\tt spinpol} is {\tt .true.}, then the spin-polarised Hamiltonian is
! solved as a second-variational step using two-component spinors in the
! Kohn-Sham magnetic field. The first variational scalar wavefunctions are
! used as a basis for setting this Hamiltonian.
!
! \block{spinsprl}{
! {\tt spinsprl} & set to {\tt .true.} if a spin-spiral calculation is
! required & logical & {\tt .false.}}
! Experimental feature for the calculation of spin-spiral states. See
! {\tt vqlss} for details.
!
! \block{sppath}{
! {\tt sppath} & path where the species files can be found & string & null}
! Note that the forward slash {\tt /} at the end of the path must be included.
!
! \block{ssdph}{
! {\tt ssdph} & set to {\tt .true.} if a complex de-phasing factor is to be
! used in spin-spiral calculations & logical & {\tt .true.}}
! If this is {\tt .true.} then spin-spiral wavefunctions in each muffin-tin at
! position ${\bf r}_{\alpha}$ are de-phased by the matrix
! $$ \begin{pmatrix} e^{-i{\bf q}\cdot{\bf r}_{\alpha}/2} & 0 \\
! 0 & e^{i{\bf q}\cdot{\bf r}_{\alpha}/2} \end{pmatrix}. $$
! In simple situations, this has the advantage of producing magnon dynamical
! matrices which are already in diagonal form. This option should be used with
! care, and a full understanding of the spin-spiral configuration is required.
! See {\tt spinsprl}.
!
! \block{stype}{
! {\tt stype} & integer defining the type of smearing to be used & integer &
! $3$}
! A smooth approximation to the Dirac delta function is needed to compute the
! occupancies of the Kohn-Sham states. The variable {\tt swidth} determines
! the width of the approximate delta function. Currently implemented are
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! 0 & Gaussian \\
! 1 & Methfessel-Paxton order 1, Phys. Rev. B {\bf 40}, 3616 (1989) \\
! 2 & Methfessel-Paxton order 2 \\
! 3 & Fermi-Dirac
! \end{tabularx}
! \vskip 6pt
! See also {\tt autoswidth}, {\tt swidth} and {\tt tempk}.
!
! \block{swidth}{
! {\tt swidth} & width of the smooth approximation to the Dirac delta
! function & real & $0.001$}
! See {\tt stype} for details and the variable {\tt tempk}.
!
! \newpage
! \block{tasks}{
! {\tt task(i) } & the $i$th task & integer & $-1$}
! A list of tasks for the code to perform sequentially. The list should be
! terminated with a blank line. Each task has an associated integer as
! follows:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! -1 & Write out the version number of the code. \\
! 0 & Ground state run starting from the atomic densities. \\
! 1 & Resumption of ground-state run using density in {\tt STATE.OUT}. \\
! 2 & Geometry optimisation run starting from the atomic densities, with
! atomic positions written to {\tt GEOMETRY.OUT}. \\
! 3 & Resumption of geometry optimisation run using density in {\tt STATE.OUT}
! but with positions from {\tt elk.in}. \\
! 5 & Ground state Hartree-Fock run. \\
! 10 & Total, partial and interstitial density of states (DOS). \\
! 14 & Plots the smooth Dirac delta and Heaviside step functions used by the
! code to calculate occupancies. \\
! 15 & Output ${\bf L}$, ${\bf S}$ and ${\bf J}$ total expectation values. \\
! 16 & Output ${\bf L}$, ${\bf S}$ and ${\bf J}$ expectation values for each
! $k$-point and state in {\tt kstlist}. \\
! 20 & Band structure plot. \\
! 21 & Band structure plot which includes total and angular momentum
! characters for every atom. \\
! 22 & Band structure plot which includes $(l,m)$ character for every atom. \\
! 23 & Band structure plot which includes spin character for every atom. \\
! 25 & Compute the effective mass tensor at the $k$-point given by
! {\tt vklem}. \\
! 31, 32, 33 & 1/2/3D charge density plot. \\
! 41, 42, 43 & 1/2/3D exchange-correlation and Coulomb potential plots. \\
! 51, 52, 53 & 1/2/3D electron localisation function (ELF) plot. \\
! 61, 62, 63 & 1/2/3D wavefunction plot:
! $\left|\Psi_{i{\bf k}}({\bf r})\right|^2$. \\
! 65 & Write the core wavefunctions to file for plotting. \\
! 71, 72, 73 & 1/2/3D plot of magnetisation vector field,
! ${\bf m}({\bf r})$. \\
! 81, 82, 83 & 1/2/3D plot of exchange-correlation magnetic vector field,
! ${\bf B}_{\rm xc}({\bf r})$. \\
! 91, 92, 93 & 1/2/3D plot of $\nabla\cdot{\bf B}_{\rm xc}({\bf r})$. \\
! 100 & 3D Fermi surface plot using the scalar product
! $p({\bf k})=\Pi_i(\epsilon_{i{\bf k}}-\epsilon_{\rm F})$. \\
! 101 & 3D Fermi surface plot using separate bands (minus the Fermi
! energy). \\
! 102 & 3D Fermi surface which can be plotted with XCrysDen. \\
! 105 & 3D nesting function plot. \\
! 110 & Calculation of M\"{o}ssbauer contact charge densities and magnetic
! fields at the nuclear sites. \\
! 115 & Calculation of the electric field gradient (EFG) at the nuclear
! sites. \\
! 120 & Output of the momentum matrix elements
! $\langle\Psi_{i{\bf k}}|-i\nabla|\Psi_{j{\bf k}}\rangle$. \\
! 121 & Linear optical dielectric response tensor calculated within the random
! phase approximation (RPA) and in the $q\rightarrow 0$ limit, with no
! microscopic contributions. \\
! 122 & Magneto optical Kerr effect (MOKE) angle. \\
! 125 & Non-linear optical second harmonic generation.
! \end{tabularx}
!
! \begin{tabularx}{\textwidth}[h]{lX}
! 130 & Output matrix elements of the type
! $\langle\Psi_{i{\bf k+q}}|\exp[i({\bf G+q})\cdot{\bf r}]|
! \Psi_{j{\bf k}}\rangle$. \\
! 135 & Output all wavefunctions expanded in the plane wave basis up to a
! cut-off defined by {\tt rgkmax}. \\
! 140 & Energy loss near edge structure (ELNES). \\
! 141, 142, 143 & 1/2/3D plot of the electric field
! ${\bf E}({\bf r})\equiv\nabla V_{\rm C}({\bf r})$. \\
! 151, 152, 153 & 1/2/3D plot of
! ${\bf m}({\bf r})\times{\bf B}_{\rm xc}({\bf r})$. \\
! 162 & Scanning-tunneling microscopy (STM) image. \\
! 180 & Generate the RPA inverse dielectric function with local contributions
! and write it to file. \\
! 185 & Write the Bethe-Salpeter equation (BSE) Hamiltonian to file. \\
! 186 & Diagonalise the BSE Hamiltonian and write the eigenvectors and
! eigenvalues to file. \\
! 187 & Output the BSE dielectric response function. \\
! 190 & Write the atomic geometry to file for plotting with XCrySDen and
! V\_Sim. \\
! 195 & Calculation of X-ray density structure factors. \\
! 196 & Calculation of magnetic structure factors. \\
! 200 & Calculation of phonon dynamical matrices on a $q$-point set defined by
! {\tt ngridq} using the supercell method. \\
! 202 & Phonon dry run: just produce a set of empty DYN files. \\
! 205 & Calculation of phonon dynamical matrices using density functional
! perturbation theory (DFPT). \\
! 210 & Phonon density of states. \\
! 220 & Phonon dispersion plot. \\
! 230 & Phonon frequencies and eigenvectors for an arbitrary $q$-point. \\
! 240, 241 & Generate the ${\bf q}$-dependent phonon linewidths and
! electron-phonon coupling constants and write them to file. \\
! 245 & Phonon linewidths plot. \\
! 250 & Eliashberg function $\alpha^2F(\omega)$, electron-phonon coupling
! constant $\lambda$, and the McMillan-Allen-Dynes critical temperature
! $T_c$. \\
! 300 & Reduced density matrix functional theory (RDMFT) calculation. \\
! 320 & Time-dependent density functional theory (TDDFT) calculation of the
! dielectric response function including microscopic contributions. \\
! 330, 331 & TDDFT calculation of the spin-polarised response function for
! arbitrary ${\bf q}$-vectors. Task 331 writes the entire response function
! $\overleftrightarrow{\chi}({\bf G},{\bf G}',q,\omega)$ to file. \\
! 400 & Calculation of tensor moments and corresponding DFT+$U$ Hartree-Fock
! energy contributions. \\
! 450 & Generates a laser pulse in the form of a time-dependent vector
! potential ${\bf A}(t)$ and writes it to AFIELDT.OUT. \\
! 460 & Time evolution run using TDDFT under the influence of ${\bf A}(t)$.
! \end{tabularx}
!
! \block{tau0atp}{
! {\tt tau0atp} & the step size to be used for atomic position optimisation &
! real & $0.25$}
! The position of atom $\alpha$ is updated on step $m$ of a geometry
! optimisation run using
! $$ {\bf r}_{\alpha}^{m+1}={\bf r}_{\alpha}^m+\tau_{\alpha}^m
! \left({\bf F}_{\alpha}^m+{\bf F}_{\alpha}^{m-1}\right), $$
! where $\tau_{\alpha}$ is set to {\tt tau0atp} for $m=0$, and incremented by
! the same amount if the atom is moving in the same direction between steps.
! If the direction changes then $\tau_{\alpha}$ is reset to {\tt tau0atp}.
!
! \block{tau0latv}{
! {\tt tau0latv} & the step size to be used for lattice vector optimisation &
! real & $0.25$}
! This parameter is used for lattice vector optimisation in a procedure
! identical to that for atomic position optimisation. See {\tt tau0atp} and
! {\tt latvopt}.
!
! \block{tauoep}{
! {\tt tauoep} & step length and starting fraction for the OEP iterative
! solver & real(2) & $(0.05, 0.95)$}
! The optimised effective potential is determined using an interative method
! [Phys. Rev. Lett. 98, 196405 (2007)]. This variable sets the step length
! described in the article. The second number defines the fraction of the
! existing potential to be used as the starting point of the iterative
! procedure. These parameters are also used for inverting the Kohn-Sham
! equations as required by the self-consistent density $GW$ method. See
! {\tt maxitoep}.
!
! \block{taufsm}{
! {\tt taufsm} & the step size to be used when finding the effective magnetic
! field in fixed spin moment calculations & real & $0.01$}
! An effective magnetic field, ${\bf B}_{\rm FSM}$, is required for fixing the
! spin moment to a given value, ${\bf M}_{\rm FSM}$. This is found by adding a
! vector to the field which is proportional to the difference between the
! moment calculated in the $i$th self-consistent loop and the required moment:
! $$ {\bf B}_{\rm FSM}^{i+1}={\bf B}_{\rm FSM}^i+\lambda\left({\bf M}^i
! -{\bf M}_{\rm FSM}\right), $$
! where $\lambda$ is proportional to {\tt taufsm}. See also {\tt fsmtype},
! {\tt momfix} and {\tt spinpol}.
!
! \block{tempk}{
! {\tt tempk} & temperature $T$ of the electronic system in kelvin & real & -}
! Assigning a value to this variable sets {\tt stype} to 3 (Fermi-Dirac) and
! the smearing width to $k_{\rm B}T$.
!
! \block{tforce}{
! {\tt tforce} & set to {\tt .true.} if the force should be calculated at the
! end of the self-consistent cycle & logical & {\tt .false.}}
! This variable is automatically set to {\tt .true.} when performing geometry
! optimisation.
!
! \block{tefvit}{
! {\tt tefvit} & set to {\tt .true.} if the first-variational eigenvalue
! equation should be solved iteratively & logical & {\tt .false.}}
!
! \block{tefvr}{
! {\tt tefvr} & set to {\tt .true.} if a real symmetric eigenvalue solver
! should be used for crystals which have inversion symmetry & logical &
! {\tt .true.}}
! For crystals with inversion symmetry, the first-variational Hamiltonian and
! overlap matrices can be made real by using appropriate transformations. In
! this case, a real symmetric (instead of complex Hermitian) eigenvalue solver
! can be used. This makes the calculation about three times faster.
!
! \block{tmomfix}{
! {\tt ntmfix} & number of tensor moments (TM) to be fixed & integer & 0 \\
! \hline
! {\tt is(i)} & species number for entry $i$ & integer & - \\
! {\tt ia(i)} & atom number & integer & - \\
! {\tt (l, n)(i)} & $l$ and $n$ indices of TM & integer & - \\
! \hline
! {\tt (k, p, x, y)(i)} or & & & \\
! {\tt (k, p, r, t)(i)} & indices for the 2-index or 3-index TM,
! respectively & integer & - \\
! \hline
! {\tt z(i)} & complex TM value & complex & - \\
! \hline
! {\tt p(i)} & parity of spatial rotation & integer & - \\
! {\tt aspl(i)} & Euler angles of spatial rotation & real(3) & - \\
! {\tt aspn(i)} & Euler angles of spin rotation & real(3) & - }
! This block sets up the fixed tensor moment (FTM). There should be as many
! TM entries as {\tt ntmfix}. See {\it Phys. Rev. Lett.} {\bf 103}, 107202
! (2009) for the tensor moment indexing convention. This is a highly
! complicated feature of the code, and should only be attempted with a full
! understanding of tensor moments.
!
! \block{tmwrite}{
! {\tt tmwrite} & set to {\tt .true.} if the tensor moments and the
! corresponding decomposition of DFT+$U$ energy should be calculated
! at every loop of the self-consistent cycle & logical & {\tt .false.}}
! This variable is useful to check the convergence of the tensor moments in
! DFT+$U$ caculations. Alternatively, with {\tt task} equal to 400, one can
! calculate the tensor moments and corresponding DFT+$U$ energy contributions
! from a given density matrix and set of Slater parameters at the end of the
! self-consistent cycle.
!
! \block{tsediag}{
! {\tt tsediag} & set to {\tt .true.} if the self-energy matrix should be
! treated as diagonal & logical & {\tt .true.}}
! When this variable is {\tt .true.}, the self-energy used in a $GW$
! calculation $\Sigma_{ij}({\bf k},\omega)$ is taken to be diagonal in the
! Kohn-Sham state indices $i$ and $j$. When {\tt tsediag} is {\tt .false.},
! the entire matrix is used. See also {\tt twdiag}.
!
! \block{tshift}{
! {\tt tshift} & set to {\tt .true.} if the crystal can be shifted so that the
! atom closest to the origin is exactly at the origin &
! logical & {\tt .true.}}
!
! \block{tstime}{
! {\tt tstime} & total simulation time of time evolution run & real &
! $1000.0$}
! See also {\tt dtimes}.
!
! \block{twdiag}{
! {\tt twdiag} & set to {\tt .true.} if the screened interaction matrix should
! be treated as diagonal & logical & {\tt .false.}}
! When this variable is {\tt .true.}, the screened interaction used in a $GW$
! calculation $W({\bf G},{\bf G}',{\bf q},\omega)$ is taken to be diagonal in
! the plane wave indices ${\bf G}$ and ${\bf G}'$. See also {\tt tsediag}.
!
! \block{vhmat}{
! {\tt vhmat(1)} & matrix row 1 & real(3) & $(1.0,0.0,0.0)$ \\
! \hline
! {\tt vhmat(2)} & matrix row 2 & real(3) & $(0.0,1.0,0.0)$ \\
! \hline
! {\tt vhmat(3)} & matrix row 3 & real(3) & $(0.0,0.0,1.0)$}
! This is the transformation matrix $M$ applied to every vector $\bf H$ in the
! structure factor output files {\tt SFACRHO.OUT} and {\tt SFACMAG.OUT}. It is
! stored in the usual row-column setting and applied directly as
! ${\bf H}'=M{\bf H}$ to every vector but {\em only} when writing the output
! files. See also {\tt hmaxvr} and {\tt reduceh}.
!
! \block{vhighq}{
! {\tt vhighq} & {\tt .true.} if a very high quality parameter set should be
! used & logical & {\tt .false.}}
! Setting this to {\tt .true.} results in some default parameters being
! changed to ensure excellent convergence in most situations. See also
! {\tt highq}.
!
! \block{vklem}{
! {\tt vklem} & the $k$-point in lattice coordinates at which to compute the
! effective mass tensors & real(3) & $(0.0,0.0,0.0)$}
! See {\tt deltaem} and {\tt ndspem}.
!
! \block{vkloff}{
! {\tt vkloff } & the $k$-point offset vector in lattice coordinates &
! real(3) & $(0.0,0.0,0.0)$}
! See {\tt ngridk}.
!
! \block{vqlss}{
! {\tt vqlss} & the ${\bf q}$-vector of the spin-spiral state in lattice
! coordinates & real(3) & $(0.0,0.0,0.0)$}
! Spin-spirals arise from spinor states assumed to be of the form
! $$ \Psi^{\bf q}_{\bf k}({\bf r})=
! \left( \begin{array}{c}
! U^{{\bf q}\uparrow}_{\bf k}({\bf r})e^{i({\bf k+q/2})\cdot{\bf r}} \\
! U^{{\bf q}\downarrow}_{\bf k}({\bf r})e^{i({\bf k-q/2})\cdot{\bf r}} \\
! \end{array} \right). $$
! These are determined using a second-variational approach, and give rise to a
! magnetisation density of the form
! $$ {\bf m}^{\bf q}({\bf r})=(m_x({\bf r})\cos({\bf q \cdot r}),
! m_y({\bf r})\sin({\bf q \cdot r}),m_z({\bf r})), $$
! where $m_x$, $m_y$ and $m_z$ are lattice periodic. See also {\tt spinsprl}.
!
! \block{wmaxgw}{
! {\tt wmaxgw} & maximum Matsubara frequency for $GW$ calculations & real &
! $-5.0$}
! This defines the cut-off of the Matsubara frequencies on the imaginary
! axis for calculating the $GW$ self-energy and solving the Dyson equation.
! If this number is negative then the cut-off is taken to be
! $|{\tt wmaxgw}|\times\Delta\epsilon$, where $\Delta\epsilon$ is the
! difference between the largest and smallest Kohn-Sham valence eigenvalues.
!
! \block{wplot}{
! {\tt nwplot} & number of frequency/energy points in the DOS or optics plot &
! integer & $500$ \\
! {\tt ngrkf} & fine $k$-point grid size used for integrating functions in the
! Brillouin zone & integer & $100$ \\
! {\tt nswplot} & level of smoothing applied to DOS/optics output & integer &
! $1$ \\
! \hline
! {\tt wplot} & frequency/energy window for the DOS or optics plot & real(2) &
! $(-0.5,0.5)$}
! DOS and optics plots require integrals of the kind
! $$ g(\omega_i)=\frac{\Omega}{(2\pi)^3}\int_{\rm BZ} f({\bf k})
! \delta(\omega_i-e({\bf k}))d{\bf k}. $$
! These are calculated by first interpolating the functions $e({\bf k})$ and
! $f({\bf k})$ with the trilinear method on a much finer mesh whose size is
! determined by {\tt ngrkf}. Then the $\omega$-dependent histogram of the
! integrand is accumulated over the fine mesh. If the output function is noisy
! then either {\tt ngrkf} should be increased or {\tt nwplot} decreased.
! Alternatively, the output function can be artificially smoothed up to a
! level given by {\tt nswplot}. This is the number of successive 3-point
! averages to be applied to the function $g$.
!
! \block{wsfac}{
! {\tt wsfac} & energy window to be used when calculating density or magnetic
! structure factors & real(2) & $(-10^6,10^6)$}
! Only those states with eigenvalues within this window will contribute to the
! density or magnetisation. See also {\tt hmaxvr} and {\tt vhmat}.
!
! \block{xctype}{
! {\tt xctype} & integers defining the type of exchange-correlation functional
! to be used & integer(3) & $(3,0,0)$}
! Normally only the first value is used to define the functional type. The
! other value may be used for external libraries. Currently implemented are:
! \vskip 6pt
! \begin{tabularx}{\textwidth}[h]{lX}
! $-n$ & Exact-exchange optimised effective potential (EXX-OEP) method with
! correlation energy and potential given by functional number $n$ \\
! 1 & No exchange-correlation funtional ($E_{\rm xc}\equiv 0$) \\
! 2 & LDA, Perdew-Zunger/Ceperley-Alder, {\it Phys. Rev. B} {\bf 23}, 5048
! (1981) \\
! 3 & LSDA, Perdew-Wang/Ceperley-Alder, {\it Phys. Rev. B} {\bf 45}, 13244
! (1992) \\
! 4 & LDA, X-alpha approximation, J. C. Slater, {\it Phys. Rev.} {\bf 81}, 385
! (1951) \\
! 5 & LSDA, von Barth-Hedin, {\it J. Phys. C} {\bf 5}, 1629 (1972) \\
! 20 & GGA, Perdew-Burke-Ernzerhof, {\it Phys. Rev. Lett.} {\bf 77}, 3865
! (1996) \\
! 21 & GGA, Revised PBE, Zhang-Yang, {\it Phys. Rev. Lett.} {\bf 80}, 890
! (1998) \\
! 22 & GGA, PBEsol, Phys. Rev. Lett. 100, 136406 (2008) \\
! 26 & GGA, Wu-Cohen exchange (WC06) with PBE correlation, {\it Phys. Rev. B}
! {\bf 73}, 235116 (2006) \\
! 30 & GGA, Armiento-Mattsson (AM05) spin-unpolarised functional,
! {\it Phys. Rev. B} {\bf 72}, 085108 (2005) \\
! 100 & Libxc functionals; the second and third values of {\tt xctype} define
! the exchange and correlation functionals in the Libxc library,
! respectively \\
! \end{tabularx}
!
! \section{Contributing to Elk}
! Please bear in mind when writing code for the Elk project that it should be
! an exercise in physics and not software engineering. All code should
! therefore be kept as simple and concise as possible, and above all it should
! be easy for anyone to locate and follow the Fortran representation of the
! original mathematics. We would also appreciate the following conventions
! being adhered to:
! \begin{itemize}
! \item Strict Fortran 2003 should be used. Features which are marked as
! obsolescent in Fortran 2003 should be avoided. These include assigned
! format specifiers, labeled do-loops, computed goto statements and statement
! functions.
! \item Modules should be used in place of common blocks for declaring
! global variables. Use the existing modules to declare new global variables.
! \item Any code should be written in lower-case free form style, starting
! from column one. Try and keep the length of each line to fewer than 80
! characters using the \& character for line continuation.
! \item Every function or subroutine, no matter how small, should be in its
! own file named {\tt routine.f90}, where {\tt routine} is the function or
! subroutine name. It is recommended that the routines are named so as to
! make their purpose apparent from the name alone.
! \item Use of {\tt implicit none} is mandatory. Remember also to define the
! {\tt intent} of any passed arguments.
! \item Local allocatable arrays must be deallocated on exit of the routine to
! prevent memory leakage. Use of automatic arrays should be limited to arrays
! of small size.
! \item Every function or subroutine must be documented with the Protex source
! code documentation system. This should include a short \LaTeX\ description
! of the algorithms and methods involved. Equations which need to be
! referenced should be labeled with {\tt routine\_1}, {\tt routine\_2}, etc.
! The authorship of each new piece of code or modification should be
! indicated in the {\tt REVISION HISTORY} part of the header. See the Protex
! documentation for details.
! \item Ensure as much as possible that a routine will terminate the program
! when given improper input instead of continuing with erroneous results.
! Specifically, functions should have a well-defined domain for which they
! return accurate results. Input outside that domain should result in an
! error message and termination.
! \item Report errors prior to termination with a short description, for
! example:
! \begin{verbatim}
! write(*,*)
! write(*,'("Error(readinput): natoms <= 0 : ",I8)') natoms(is)
! write(*,'(" for species ",I4)') is
! write(*,*)
! stop
! \end{verbatim}
! \item Wherever possible, real numbers outputted as ASCII data should be
! formatted with the {\tt G18.10} specifier.
! \item Avoid redundant or repeated code: check to see if the routine you need
! already exists, before writing a new one.
! \item All reading in of ASCII data should be done in the subroutine
! {\tt readinput}. For binary data, separate routines for reading and writing
! should be used (for example {\tt writestate} and {\tt readstate}).
! \item Input filenames should be in lowercase and have the extension
! {\tt .in} . All output filenames should be in uppercase with the extension
! {\tt .OUT} .
! \item All internal units should be atomic. Input and output units should be
! atomic by default and clearly stated otherwise. Rydbergs should not be used
! under any circumstances.
! \end{itemize}
! \subsection{Licensing}
! Routines which constitute the main part of the code are released under the
! GNU General Public License (GPL). Library routines are released under the
! less restrictive GNU Lesser General Public License (LGPL). Both licenses
! are contained in the file {\tt COPYING}. Any contribution to the code must
! be licensed at the authors' discretion under either the GPL or LGPL.
! Author(s) of the code retain the copyrights. Copyright and (L)GPL
! information must be included at the beginning of every file, and no code
! will be accepted without this.
!
!EOI
elk-7.2.42/src/PaxHeaders.21776/olpistl.f90 0000644 0000000 0000000 00000000132 14061636516 014731 x ustar 00 30 mtime=1623670094.883102522
30 atime=1623670093.602103711
30 ctime=1623670094.883102522
elk-7.2.42/src/olpistl.f90 0000644 0025044 0025044 00000002375 14061636516 016775 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: olpistl
! !INTERFACE:
pure subroutine olpistl(ngp,igpig,ld,o)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! ngp : number of G+p-vectors (in,integer)
! igpig : index from G+p-vectors to G-vectors (in,integer(ngkmax))
! ld : leading dimension of o (in,integer)
! o : overlap matrix (inout,complex(*))
! !DESCRIPTION:
! Computes the interstitial contribution to the overlap matrix for the APW
! basis functions. The overlap is given by
! $$ O^{\rm I}({\bf G+k,G'+k})=\tilde{\Theta}({\bf G-G'}), $$
! where $\tilde{\Theta}$ is the characteristic function. See routine
! {\tt gencfun}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ngp,igpig(ngkmax)
integer, intent(in) :: ld
complex(8), intent(inout) :: o(ld,*)
! local variables
integer ig,j1,j2,j3,i,j
do j=1,ngp
ig=igpig(j)
j1=ivg(1,ig); j2=ivg(2,ig); j3=ivg(3,ig)
do i=1,j
ig=igpig(i)
ig=ivgig(ivg(1,ig)-j1,ivg(2,ig)-j2,ivg(3,ig)-j3)
o(i,j)=o(i,j)+cfunig(ig)
end do
end do
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/hmlistl.f90 0000644 0000000 0000000 00000000131 14061636516 014716 x ustar 00 30 mtime=1623670094.884102521
29 atime=1623670093.60310371
30 ctime=1623670094.884102521
elk-7.2.42/src/hmlistl.f90 0000644 0025044 0025044 00000003163 14061636516 016757 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: hmlistl
! !INTERFACE:
pure subroutine hmlistl(ngp,igpig,vgpc,ld,h)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! ngp : number of G+p-vectors (in,integer)
! igpig : index from G+p-vectors to G-vectors (in,integer(ngkmax))
! vgpc : G+p-vectors in Cartesian coordinates (in,real(3,ngkmax))
! ld : leading dimension of h (in,integer)
! h : Hamiltonian matrix (inout,complex(*))
! !DESCRIPTION:
! Computes the interstitial contribution to the Hamiltonian matrix for the APW
! basis functions. The Hamiltonian is given by
! $$ H^{\rm I}({\bf G+k,G'+k})=\frac{1}{2}({\bf G+k})\cdot({\bf G'+k})
! \tilde{\Theta}({\bf G-G'})+V_s({\bf G-G'}), $$
! where $V_s$ is the interstitial Kohn-Sham potential and $\tilde{\Theta}$ is
! the characteristic function. See routine {\tt gencfun}.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! arguments
integer, intent(in) :: ngp,igpig(ngkmax)
real(8), intent(in) :: vgpc(3,ngkmax)
integer, intent(in) :: ld
complex(8), intent(inout) :: h(ld,*)
! local variables
integer ig,j1,j2,j3,i,j
real(8) v1,v2,v3,t1
do j=1,ngp
ig=igpig(j)
j1=ivg(1,ig); j2=ivg(2,ig); j3=ivg(3,ig)
v1=0.5d0*vgpc(1,j); v2=0.5d0*vgpc(2,j); v3=0.5d0*vgpc(3,j)
do i=1,j
ig=igpig(i)
ig=ivgig(ivg(1,ig)-j1,ivg(2,ig)-j2,ivg(3,ig)-j3)
t1=vgpc(1,i)*v1+vgpc(2,i)*v2+vgpc(3,i)*v3
h(i,j)=h(i,j)+vsig(ig)+t1*cfunig(ig)
end do
end do
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/olpalo.f90 0000644 0000000 0000000 00000000130 14061636516 014527 x ustar 00 29 mtime=1623670094.88510252
30 atime=1623670093.605103708
29 ctime=1623670094.88510252
elk-7.2.42/src/olpalo.f90 0000644 0025044 0025044 00000001363 14061636516 016571 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
pure subroutine olpalo(is,ias,ngp,apwalm,ld,o)
use modmain
implicit none
! arguments
integer, intent(in) :: is,ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: o(ld,*)
! local variables
integer ilo,io,l,lm,i,j
real(8) t1
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do lm=l**2+1,(l+1)**2
j=ngp+idxlo(lm,ilo,ias)
do io=1,apword(l,is)
t1=oalo(io,ilo,ias)
do i=1,ngp
o(i,j)=o(i,j)+t1*conjg(apwalm(i,io,lm))
end do
end do
end do
end do
end subroutine
elk-7.2.42/src/PaxHeaders.21776/hmlalo.f90 0000644 0000000 0000000 00000000132 14061636516 014517 x ustar 00 30 mtime=1623670094.887102518
30 atime=1623670093.607103706
30 ctime=1623670094.887102518
elk-7.2.42/src/hmlalo.f90 0000644 0025044 0025044 00000002372 14061636516 016560 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
pure subroutine hmlalo(is,ias,ngp,apwalm,ld,h)
use modmain
implicit none
! arguments
integer, intent(in) :: is,ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: h(ld,*)
! local variables
integer io,ilo,i,j
integer l1,l2,l3
integer lm1,lm2,lm3
complex(8) z1
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do lm1=l1**2+1,(l1+1)**2
j=ngp+idxlo(lm1,ilo,ias)
do l3=0,lmaxapw
do lm3=l3**2+1,(l3+1)**2
do io=1,apword(l3,is)
z1=0.d0
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do lm2=l2**2+1,(l2+1)**2
z1=z1+gntyry(lm2,lm3,lm1)*hloa(lm2,io,l3,ilo,ias)
end do
end if
end do
! note that what is actually computed is the Hermitian conjugate of
if (abs(dble(z1))+abs(aimag(z1)).gt.1.d-14) then
do i=1,ngp
h(i,j)=h(i,j)+conjg(z1*apwalm(i,io,lm3))
end do
end if
end do
end do
end do
end do
end do
end subroutine
elk-7.2.42/src/PaxHeaders.21776/olplolo.f90 0000644 0000000 0000000 00000000132 14061636516 014723 x ustar 00 30 mtime=1623670094.888102517
30 atime=1623670093.608103705
30 ctime=1623670094.888102517
elk-7.2.42/src/olplolo.f90 0000644 0025044 0025044 00000001257 14061636516 016765 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
pure subroutine olplolo(is,ias,ngp,ld,o)
use modmain
implicit none
! arguments
integer, intent(in) :: is,ias,ngp,ld
complex(8), intent(inout) :: o(ld,*)
! local variables
integer ilo,jlo,l,lm,i,j
do ilo=1,nlorb(is)
l=lorbl(ilo,is)
do jlo=1,nlorb(is)
if (lorbl(jlo,is).eq.l) then
do lm=l**2+1,(l+1)**2
i=ngp+idxlo(lm,ilo,ias)
j=ngp+idxlo(lm,jlo,ias)
if (i.le.j) o(i,j)=o(i,j)+ololo(ilo,jlo,ias)
end do
end if
end do
end do
end subroutine
elk-7.2.42/src/PaxHeaders.21776/hmllolo.f90 0000644 0000000 0000000 00000000132 14061636516 014711 x ustar 00 30 mtime=1623670094.890102515
30 atime=1623670093.610103703
30 ctime=1623670094.890102515
elk-7.2.42/src/hmllolo.f90 0000644 0025044 0025044 00000001726 14061636516 016754 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
pure subroutine hmllolo(is,ias,ngp,ld,h)
use modmain
implicit none
! arguments
integer, intent(in) :: is,ias,ngp,ld
complex(8), intent(inout) :: h(ld,*)
! local variables
integer ilo,jlo,i,j
integer l1,l2,l3
integer lm1,lm2,lm3
complex(8) z1
do jlo=1,nlorb(is)
l3=lorbl(jlo,is)
do lm3=l3**2+1,(l3+1)**2
j=ngp+idxlo(lm3,jlo,ias)
do ilo=1,nlorb(is)
l1=lorbl(ilo,is)
do lm1=l1**2+1,(l1+1)**2
i=ngp+idxlo(lm1,ilo,ias)
if (i.gt.j) cycle
z1=0.d0
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do lm2=l2**2+1,(l2+1)**2
z1=z1+gntyry(lm2,lm3,lm1)*hlolo(lm2,jlo,ilo,ias)
end do
end if
end do
h(i,j)=h(i,j)+z1
end do
end do
end do
end do
end subroutine
elk-7.2.42/src/PaxHeaders.21776/olpaa.f90 0000644 0000000 0000000 00000000132 14061636516 014337 x ustar 00 30 mtime=1623670094.891102514
30 atime=1623670093.612103701
30 ctime=1623670094.891102514
elk-7.2.42/src/olpaa.f90 0000644 0025044 0025044 00000001344 14061636516 016376 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine olpaa(tor,is,ngp,apwalm,ld,o)
use modmain
implicit none
! arguments
logical, intent(in) :: tor
integer, intent(in) :: is,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: o(*)
! local variables
integer io,l,lm,i
! automatic arrays
complex(8) a(lmoapw(is),ngp)
i=0
do l=0,lmaxapw
do lm=l**2+1,(l+1)**2
do io=1,apword(l,is)
i=i+1
a(i,1:ngp)=apwalm(1:ngp,io,lm)
end do
end do
end do
call zmctmu(tor,lmoapw(is),ngp,a,a,ld,o)
end subroutine
elk-7.2.42/src/PaxHeaders.21776/hmlaa.f90 0000644 0000000 0000000 00000000130 14061636516 014323 x ustar 00 30 mtime=1623670094.893102512
28 atime=1623670093.6131037
30 ctime=1623670094.893102512
elk-7.2.42/src/hmlaa.f90 0000644 0025044 0025044 00000004260 14061636516 016364 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: hmlaa
! !INTERFACE:
subroutine hmlaa(thr,is,ias,ngp,apwalm,ld,h)
! !USES:
use modmain
! !INPUT/OUTPUT PARAMETERS:
! thr : .true. if the matrix h is real valued (in,logical)
! is : species number (in,integer)
! ias : joint atom and species number (in,integer)
! ngp : number of G+p-vectors (in,integer)
! apwalm : APW matching coefficients (in,complex(ngkmax,apwordmax,lmmaxapw))
! ld : leading dimension of h (in,integer)
! h : Hamiltonian matrix (inout,complex(*))
! !DESCRIPTION:
! Calculates the APW-APW contribution to the Hamiltonian matrix.
!
! !REVISION HISTORY:
! Created October 2002 (JKD)
!EOP
!BOC
implicit none
! arguments
logical, intent(in) :: thr
integer, intent(in) :: is,ias,ngp
complex(8), intent(in) :: apwalm(ngkmax,apwordmax,lmmaxapw)
integer, intent(in) :: ld
complex(8), intent(inout) :: h(*)
! local variables
integer lmo,io,jo,i
integer l1,l2,l3
integer lm1,lm2,lm3
real(8) t0
complex(8) z1
! automatic arrays
complex(8) a(lmoapw(is),ngp),b(lmoapw(is),ngp)
lmo=lmoapw(is)
t0=0.5d0*rmt(is)**2
i=0
do l1=0,lmaxapw
do lm1=l1**2+1,(l1+1)**2
do io=1,apword(l1,is)
i=i+1
b(i,:)=0.d0
do l3=0,lmaxapw
do lm3=l3**2+1,(l3+1)**2
do jo=1,apword(l3,is)
z1=0.d0
! kinetic and potential contribution
do l2=0,lmaxo
if (mod(l1+l2+l3,2).eq.0) then
do lm2=l2**2+1,(l2+1)**2
z1=z1+gntyry(lm2,lm3,lm1)*haa(lm2,jo,l3,io,l1,ias)
end do
end if
end do
! kinetic surface contribution
if (lm1.eq.lm3) then
z1=z1+t0*apwfr(nrmt(is),1,io,l1,ias)*apwdfr(jo,l1,ias)
end if
if (abs(dble(z1))+abs(aimag(z1)).gt.1.d-14) then
call zaxpy(ngp,z1,apwalm(:,jo,lm3),1,b(i,1),lmo)
end if
end do
end do
end do
a(i,1:ngp)=apwalm(1:ngp,io,lm1)
end do
end do
end do
call zmctmu(thr,lmo,ngp,a,b,ld,h)
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/gengclg.f90 0000644 0000000 0000000 00000000132 14061636516 014651 x ustar 00 30 mtime=1623670094.894102511
30 atime=1623670093.615103699
30 ctime=1623670094.894102511
elk-7.2.42/src/gengclg.f90 0000644 0025044 0025044 00000000573 14061636516 016713 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2017 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine gengclg
use modmain
implicit none
! local variables
if (allocated(gclg)) deallocate(gclg)
allocate(gclg(ngvec))
gclg(1)=0.d0
gclg(2:ngvec)=fourpi/gc(2:ngvec)**2
end subroutine
elk-7.2.42/src/PaxHeaders.21776/rhomagsh.f90 0000644 0000000 0000000 00000000130 14061636516 015051 x ustar 00 29 mtime=1623670094.89610251
30 atime=1623670093.617103697
29 ctime=1623670094.89610251
elk-7.2.42/src/rhomagsh.f90 0000644 0025044 0025044 00000002357 14061636516 017117 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2009 J. K. Dewhurst, S. Sharma and E. K. U. Gross
! This file is distributed under the terms of the GNU Lesser General Public
! License. See the file COPYING for license details.
!BOP
! !ROUTINE: rhomagsh
! !INTERFACE:
subroutine rhomagsh
! !USES:
use modmain
use modomp
! !DESCRIPTION:
! Converts the muffin-tin density and magnetisation from spherical coordinates
! to a spherical harmonic expansion. See {\tt rhomagk}.
!
! !REVISION HISTORY:
! Created January 2009 (JKD)
!EOP
!BOC
implicit none
! local variables
integer idm,is,ias
integer npc,nthd
! automatic arrays
real(8) rfmt(npcmtmax)
call holdthd(natmtot,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(rfmt,is,npc,idm) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
npc=npcmt(is)
! convert the density to spherical harmonics
rfmt(1:npc)=rhomt(1:npc,ias)
call rfsht(nrcmt(is),nrcmti(is),rfmt,rhomt(:,ias))
end do
!$OMP END DO NOWAIT
do idm=1,ndmag
!$OMP DO
do ias=1,natmtot
is=idxis(ias)
npc=npcmt(is)
! convert the magnetisation to spherical harmonics
rfmt(1:npc)=magmt(1:npc,ias,idm)
call rfsht(nrcmt(is),nrcmti(is),rfmt,magmt(:,ias,idm))
end do
!$OMP END DO
end do
!$OMP END PARALLEL
call freethd(nthd)
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/charge.f90 0000644 0000000 0000000 00000000132 14061636516 014474 x ustar 00 30 mtime=1623670094.897102509
30 atime=1623670093.618103696
30 ctime=1623670094.897102509
elk-7.2.42/src/charge.f90 0000644 0025044 0025044 00000002011 14061636516 016523 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: charge
! !INTERFACE:
subroutine charge
! !USES:
use modmain
use modtest
! !DESCRIPTION:
! Computes the muffin-tin, interstitial and total charges by integrating the
! density.
!
! !REVISION HISTORY:
! Created April 2003 (JKD)
!EOP
!BOC
implicit none
! local variables
integer is,ias
real(8) t1
! external functions
real(8), external :: rfmtint
! find the muffin-tin charges
chgmttot=0.d0
do ias=1,natmtot
is=idxis(ias)
chgmt(ias)=rfmtint(nrmt(is),nrmti(is),wrmt(:,is),rhomt(:,ias))
chgmttot=chgmttot+chgmt(ias)
end do
! find the interstitial charge
t1=dot_product(rhoir(1:ngtot),cfunir(1:ngtot))
chgir=t1*omega/dble(ngtot)
! total calculated charge
chgcalc=chgmttot+chgir
! write total calculated charge to test file
call writetest(400,'calculated total charge',tol=1.d-6,rv=chgcalc)
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/moment.f90 0000644 0000000 0000000 00000000132 14061636516 014542 x ustar 00 30 mtime=1623670094.899102507
30 atime=1623670093.620103694
30 ctime=1623670094.899102507
elk-7.2.42/src/moment.f90 0000644 0025044 0025044 00000002537 14061636516 016606 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: moment
! !INTERFACE:
subroutine moment
! !USES:
use modmain
use modtest
! !DESCRIPTION:
! Computes the muffin-tin, interstitial and total moments by integrating the
! magnetisation.
!
! !REVISION HISTORY:
! Created January 2005 (JKD)
!EOP
!BOC
implicit none
! local variables
integer idm,is,ias
real(8) t1
! external functions
real(8), external :: rfmtint
if (.not.spinpol) then
mommt(:,:)=0.d0
mommttot(:)=0.d0
momir(:)=0.d0
momtot(:)=0.d0
momtotm=0.d0
return
end if
! find the muffin-tin moments
mommttot(:)=0.d0
do idm=1,ndmag
do ias=1,natmtot
is=idxis(ias)
mommt(idm,ias)=rfmtint(nrmt(is),nrmti(is),wrmt(:,is),magmt(:,ias,idm))
mommttot(idm)=mommttot(idm)+mommt(idm,ias)
end do
end do
! find the interstitial moments
do idm=1,ndmag
t1=dot_product(magir(1:ngtot,idm),cfunir(1:ngtot))
momir(idm)=t1*omega/dble(ngtot)
end do
momtot(:)=mommttot(:)+momir(:)
! total moment magnitude
if (ncmag) then
momtotm=sqrt(momtot(1)**2+momtot(2)**2+momtot(3)**2)
else
momtotm=abs(momtot(1))
end if
! write total moment magnitude to test file
call writetest(450,'total moment magnitude',tol=1.d-3,rv=momtotm)
end subroutine
!EOC
elk-7.2.42/src/PaxHeaders.21776/rfint0.f90 0000644 0000000 0000000 00000000132 14061636516 014445 x ustar 00 30 mtime=1623670094.900102506
30 atime=1623670093.622103692
30 ctime=1623670094.900102506
elk-7.2.42/src/rfint0.f90 0000644 0025044 0025044 00000001367 14061636516 016511 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2018 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
subroutine rfint0(rf0,rfmt,rfir)
use modmain
implicit none
! arguments
real(8), intent(in) :: rf0
real(8), intent(inout) :: rfmt(npmtmax,natmtot),rfir(ngtot)
! local variables
integer is,ias
integer nr,nri,ir,i
real(8) t1
! external functions
real(8), external :: rfint
t1=rfint(rfmt,rfir)
t1=rf0-t1/omega
rfir(:)=rfir(:)+t1
t1=t1/y00
do ias=1,natmtot
is=idxis(ias)
nr=nrmt(is)
nri=nrmti(is)
i=1
do ir=1,nri
rfmt(i,ias)=rfmt(i,ias)+t1
i=i+lmmaxi
end do
do ir=nri+1,nr
rfmt(i,ias)=rfmt(i,ias)+t1
i=i+lmmaxo
end do
end do
end subroutine
elk-7.2.42/src/PaxHeaders.21776/potnucl.f90 0000644 0000000 0000000 00000000132 14061636516 014727 x ustar 00 30 mtime=1623670094.902102504
30 atime=1623670093.623103691
30 ctime=1623670094.902102504
elk-7.2.42/src/potnucl.f90 0000644 0025044 0025044 00000003132 14061636516 016763 0 ustar 00dewhurst dewhurst 0000000 0000000
! Copyright (C) 2008 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.
!BOP
! !ROUTINE: potnucl
! !INTERFACE:
subroutine potnucl(ptnucl,nr,r,zn,vn)
! !INPUT/OUTPUT PARAMETERS:
! ptnucl : .true. if the nucleus is a point charge (in,logical)
! nr : number of radial mesh points (in,integer)
! r : radial mesh (in,real(nr))
! zn : nuclear charge (in,real)
! vn : potential on radial mesh (out,real(nr))
! !DESCRIPTION:
! Computes the nuclear Coulomb potential on a radial mesh. The nuclear radius
! $R$ is estimated from the nuclear charge $Z$ and the potential is given by
! $$ V(r)=\begin{cases}
! Z(3R^2-r^2)/2R^3 & r